From: Paul Eggert Date: Sun, 1 Jan 2017 09:10:47 +0000 (-0800) Subject: Merge from origin/emacs-25 X-Git-Tag: archive/raspbian/1%29.2+1-2+rpi1^2~5^2~21^2~1989 X-Git-Url: https://dgit.raspbian.org/%22http:/www.example.com/cgi/%22https:/www.github.com/%22bookmarks:///%22http:/www.example.com/cgi/%22https:/www.github.com/%22bookmarks:/?a=commitdiff_plain;h=bcf244ef9be0fe61f4b9a48d3412b2c8a9f1edb9;p=emacs.git Merge from origin/emacs-25 2e2a806 Fix copyright years by hand 5badc81 Update copyright year to 2017 --- bcf244ef9be0fe61f4b9a48d3412b2c8a9f1edb9 diff --cc doc/misc/texinfo.tex index c8913ab918e,922e0015d78..954dceb6427 --- a/doc/misc/texinfo.tex +++ b/doc/misc/texinfo.tex @@@ -3,12 -3,9 +3,9 @@@ % Load plain if necessary, i.e., if running under initex. \expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi % -\def\texinfoversion{2016-04-14.07} +\def\texinfoversion{2016-09-18.18} % - % Copyright 1985, 1986, 1988, 1990, 1991, 1992, 1993, 1994, 1995, - % 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, - % 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 - % Free Software Foundation, Inc. + % Copyright 1985-1986, 1988, 1990-2017 Free Software Foundation, Inc. % % This texinfo.tex file is free software: you can redistribute it and/or % modify it under the terms of the GNU General Public License as diff --cc etc/emacs-buffer.gdb index 61b06f23b2c,db58eeb8e94..9659ccdc644 --- a/etc/emacs-buffer.gdb +++ b/etc/emacs-buffer.gdb @@@ -1,8 -1,8 +1,8 @@@ # emacs-buffer.gdb --- gdb macros for recovering buffers from emacs coredumps - # Copyright (C) 2005-2016 Free Software Foundation, Inc. + # Copyright (C) 2005-2017 Free Software Foundation, Inc. -# Maintainer: Noah Friedman +# Author: Noah Friedman # Created: 2005-04-28 # This file is part of GNU Emacs. diff --cc lib/secure_getenv.c index 88a60dc33c3,aacbde81ad8..df53dea0b2f --- a/lib/secure_getenv.c +++ b/lib/secure_getenv.c @@@ -1,6 -1,6 +1,6 @@@ -/* Look up an environment variable more securely. +/* Look up an environment variable, returning NULL in insecure situations. - Copyright 2013-2016 Free Software Foundation, Inc. + Copyright 2013-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published diff --cc lisp/auth-source.el index 62d9a4521c0,00000000000..c26935fcc97 mode 100644,000000..100644 --- a/lisp/auth-source.el +++ b/lisp/auth-source.el @@@ -1,2149 -1,0 +1,2149 @@@ +;;; auth-source.el --- authentication sources for Gnus and Emacs -*- lexical-binding: t -*- + - ;; Copyright (C) 2008-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2008-2017 Free Software Foundation, Inc. + +;; Author: Ted Zlatanov +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This is the auth-source.el package. It lets users tell Gnus how to +;; authenticate in a single place. Simplicity is the goal. Instead +;; of providing 5000 options, we'll stick to simple, easy to +;; understand options. + +;; See the auth.info Info documentation for details. + +;; TODO: + +;; - never decode the backend file unless it's necessary +;; - a more generic way to match backends and search backend contents +;; - absorb netrc.el and simplify it +;; - protect passwords better +;; - allow creating and changing netrc lines (not files) e.g. change a password + +;;; Code: + +(require 'password-cache) + +(eval-when-compile (require 'cl-lib)) +(require 'eieio) + +(autoload 'secrets-create-item "secrets") +(autoload 'secrets-delete-item "secrets") +(autoload 'secrets-get-alias "secrets") +(autoload 'secrets-get-attributes "secrets") +(autoload 'secrets-get-secret "secrets") +(autoload 'secrets-list-collections "secrets") +(autoload 'secrets-search-items "secrets") + +(autoload 'rfc2104-hash "rfc2104") + +(autoload 'plstore-open "plstore") +(autoload 'plstore-find "plstore") +(autoload 'plstore-put "plstore") +(autoload 'plstore-delete "plstore") +(autoload 'plstore-save "plstore") +(autoload 'plstore-get-file "plstore") + +(eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor' +(autoload 'epg-make-context "epg") +(autoload 'epg-context-set-passphrase-callback "epg") +(autoload 'epg-decrypt-string "epg") +(autoload 'epg-encrypt-string "epg") + +(autoload 'help-mode "help-mode" nil t) + +(defvar secrets-enabled) + +(defgroup auth-source nil + "Authentication sources." + :version "23.1" ;; No Gnus + :group 'gnus) + +;;;###autoload +(defcustom auth-source-cache-expiry 7200 + "How many seconds passwords are cached, or nil to disable +expiring. Overrides `password-cache-expiry' through a +let-binding." + :version "24.1" + :group 'auth-source + :type '(choice (const :tag "Never" nil) + (const :tag "All Day" 86400) + (const :tag "2 Hours" 7200) + (const :tag "30 Minutes" 1800) + (integer :tag "Seconds"))) + +;; The slots below correspond with the `auth-source-search' spec, +;; so a backend with :host set, for instance, would match only +;; searches for that host. Normally they are nil. +(defclass auth-source-backend () + ((type :initarg :type + :initform 'netrc + :type symbol + :custom symbol + :documentation "The backend type.") + (source :initarg :source + :type string + :custom string + :documentation "The backend source.") + (host :initarg :host + :initform t + :type t + :custom string + :documentation "The backend host.") + (user :initarg :user + :initform t + :type t + :custom string + :documentation "The backend user.") + (port :initarg :port + :initform t + :type t + :custom string + :documentation "The backend protocol.") + (data :initarg :data + :initform nil + :documentation "Internal backend data.") + (create-function :initarg :create-function + :initform ignore + :type function + :custom function + :documentation "The create function.") + (search-function :initarg :search-function + :initform ignore + :type function + :custom function + :documentation "The search function."))) + +(defcustom auth-source-protocols '((imap "imap" "imaps" "143" "993") + (pop3 "pop3" "pop" "pop3s" "110" "995") + (ssh "ssh" "22") + (sftp "sftp" "115") + (smtp "smtp" "25")) + "List of authentication protocols and their names" + + :group 'auth-source + :version "23.2" ;; No Gnus + :type '(repeat :tag "Authentication Protocols" + (cons :tag "Protocol Entry" + (symbol :tag "Protocol") + (repeat :tag "Names" + (string :tag "Name"))))) + +;; Generate all the protocols in a format Customize can use. +;; TODO: generate on the fly from auth-source-protocols +(defconst auth-source-protocols-customize + (mapcar (lambda (a) + (let ((p (car-safe a))) + (list 'const + :tag (upcase (symbol-name p)) + p))) + auth-source-protocols)) + +(defvar auth-source-creation-defaults nil + ;; FIXME: AFAICT this is not set (or let-bound) anywhere! + "Defaults for creating token values. Usually let-bound.") + +(defvar auth-source-creation-prompts nil + "Default prompts for token values. Usually let-bound.") + +(make-obsolete 'auth-source-hide-passwords nil "Emacs 24.1") + +(defcustom auth-source-save-behavior 'ask + "If set, auth-source will respect it for save behavior." + :group 'auth-source + :version "23.2" ;; No Gnus + :type `(choice + :tag "auth-source new token save behavior" + (const :tag "Always save" t) + (const :tag "Never save" nil) + (const :tag "Ask" ask))) + +;; TODO: make the default (setq auth-source-netrc-use-gpg-tokens `((,(if (boundp 'epa-file-auto-mode-alist-entry) (car epa-file-auto-mode-alist-entry) "\\.gpg\\'") never) (t gpg))) +;; TODO: or maybe leave as (setq auth-source-netrc-use-gpg-tokens 'never) + +(defcustom auth-source-netrc-use-gpg-tokens 'never + "Set this to tell auth-source when to create GPG password +tokens in netrc files. It's either an alist or `never'. +Note that if EPA/EPG is not available, this should NOT be used." + :group 'auth-source + :version "23.2" ;; No Gnus + :type `(choice + (const :tag "Always use GPG password tokens" (t gpg)) + (const :tag "Never use GPG password tokens" never) + (repeat :tag "Use a lookup list" + (list + (choice :tag "Matcher" + (const :tag "Match anything" t) + (const :tag "The EPA encrypted file extensions" + ,(if (boundp 'epa-file-auto-mode-alist-entry) + (car epa-file-auto-mode-alist-entry) + "\\.gpg\\'")) + (regexp :tag "Regular expression")) + (choice :tag "What to do" + (const :tag "Save GPG-encrypted password tokens" gpg) + (const :tag "Don't encrypt tokens" never)))))) + +(defvar auth-source-magic "auth-source-magic ") + +(defcustom auth-source-do-cache t + "Whether auth-source should cache information with `password-cache'." + :group 'auth-source + :version "23.2" ;; No Gnus + :type `boolean) + +(defcustom auth-source-debug nil + "Whether auth-source should log debug messages. + +If the value is nil, debug messages are not logged. + +If the value is t, debug messages are logged with `message'. In +that case, your authentication data will be in the clear (except +for passwords). + +If the value is a function, debug messages are logged by calling + that function using the same arguments as `message'." + :group 'auth-source + :version "23.2" ;; No Gnus + :type `(choice + :tag "auth-source debugging mode" + (const :tag "Log using `message' to the *Messages* buffer" t) + (const :tag "Log all trivia with `message' to the *Messages* buffer" + trivia) + (function :tag "Function that takes arguments like `message'") + (const :tag "Don't log anything" nil))) + +(defcustom auth-sources '("~/.authinfo" "~/.authinfo.gpg" "~/.netrc") + "List of authentication sources. +Each entry is the authentication type with optional properties. +Entries are tried in the order in which they appear. +See Info node `(auth)Help for users' for details. + +If an entry names a file with the \".gpg\" extension and you have +EPA/EPG set up, the file will be encrypted and decrypted +automatically. See Info node `(epa)Encrypting/decrypting gpg files' +for details. + +It's best to customize this with `\\[customize-variable]' because the choices +can get pretty complex." + :group 'auth-source + :version "24.1" ;; No Gnus + :type `(repeat :tag "Authentication Sources" + (choice + (string :tag "Just a file") + (const :tag "Default Secrets API Collection" default) + (const :tag "Login Secrets API Collection" "secrets:Login") + (const :tag "Temp Secrets API Collection" "secrets:session") + + (const :tag "Default internet Mac OS Keychain" + macos-keychain-internet) + + (const :tag "Default generic Mac OS Keychain" + macos-keychain-generic) + + (list :tag "Source definition" + (const :format "" :value :source) + (choice :tag "Authentication backend choice" + (string :tag "Authentication Source (file)") + (list + :tag "Secret Service API/KWallet/GNOME Keyring" + (const :format "" :value :secrets) + (choice :tag "Collection to use" + (string :tag "Collection name") + (const :tag "Default" default) + (const :tag "Login" "Login") + (const + :tag "Temporary" "session"))) + (list + :tag "Mac OS internet Keychain" + (const :format "" + :value :macos-keychain-internet) + (choice :tag "Collection to use" + (string :tag "internet Keychain path") + (const :tag "default" default))) + (list + :tag "Mac OS generic Keychain" + (const :format "" + :value :macos-keychain-generic) + (choice :tag "Collection to use" + (string :tag "generic Keychain path") + (const :tag "default" default)))) + (repeat :tag "Extra Parameters" :inline t + (choice :tag "Extra parameter" + (list + :tag "Host" + (const :format "" :value :host) + (choice :tag "Host (machine) choice" + (const :tag "Any" t) + (regexp + :tag "Regular expression"))) + (list + :tag "Protocol" + (const :format "" :value :port) + (choice + :tag "Protocol" + (const :tag "Any" t) + ,@auth-source-protocols-customize)) + (list :tag "User" :inline t + (const :format "" :value :user) + (choice + :tag "Personality/Username" + (const :tag "Any" t) + (string + :tag "Name"))))))))) + +(defcustom auth-source-gpg-encrypt-to t + "List of recipient keys that `authinfo.gpg' encrypted to. +If the value is not a list, symmetric encryption will be used." + :group 'auth-source + :version "24.1" ;; No Gnus + :type '(choice (const :tag "Symmetric encryption" t) + (repeat :tag "Recipient public keys" + (string :tag "Recipient public key")))) + +;; temp for debugging +;; (unintern 'auth-source-protocols) +;; (unintern 'auth-sources) +;; (customize-variable 'auth-sources) +;; (setq auth-sources nil) +;; (format "%S" auth-sources) +;; (customize-variable 'auth-source-protocols) +;; (setq auth-source-protocols nil) +;; (format "%S" auth-source-protocols) +;; (auth-source-pick nil :host "a" :port 'imap) +;; (auth-source-user-or-password "login" "imap.myhost.com" 'imap) +;; (auth-source-user-or-password "password" "imap.myhost.com" 'imap) +;; (auth-source-user-or-password-imap "login" "imap.myhost.com") +;; (auth-source-user-or-password-imap "password" "imap.myhost.com") +;; (auth-source-protocol-defaults 'imap) + +;; (let ((auth-source-debug 'debug)) (auth-source-do-debug "hello")) +;; (let ((auth-source-debug t)) (auth-source-do-debug "hello")) +;; (let ((auth-source-debug nil)) (auth-source-do-debug "hello")) +(defun auth-source-do-debug (&rest msg) + (when auth-source-debug + (apply #'auth-source-do-warn msg))) + +(defun auth-source-do-trivia (&rest msg) + (when (or (eq auth-source-debug 'trivia) + (functionp auth-source-debug)) + (apply #'auth-source-do-warn msg))) + +(defun auth-source-do-warn (&rest msg) + (apply + ;; set logger to either the function in auth-source-debug or 'message + ;; note that it will be 'message if auth-source-debug is nil + (if (functionp auth-source-debug) + auth-source-debug + 'message) + msg)) + + +;; (auth-source-read-char-choice "enter choice? " '(?a ?b ?q)) +(defun auth-source-read-char-choice (prompt choices) + "Read one of CHOICES by `read-char-choice', or `read-char'. +`dropdown-list' support is disabled because it doesn't work reliably. +Only one of CHOICES will be returned. The PROMPT is augmented +with \"[a/b/c] \" if CHOICES is \(?a ?b ?c)." + (when choices + (let* ((prompt-choices + (apply #'concat + (cl-loop for c in choices collect (format "%c/" c)))) + (prompt-choices (concat "[" (substring prompt-choices 0 -1) "] ")) + (full-prompt (concat prompt prompt-choices)) + k) + + (while (not (memq k choices)) + (setq k (read-char-choice full-prompt choices))) + k))) + +;; (auth-source-pick nil :host "any" :port 'imap :user "joe") +;; (auth-source-pick t :host "any" :port 'imap :user "joe") +;; (setq auth-sources '((:source (:secrets default) :host t :port t :user "joe") +;; (:source (:secrets "session") :host t :port t :user "joe") +;; (:source (:secrets "Login") :host t :port t) +;; (:source "~/.authinfo.gpg" :host t :port t))) + +;; (setq auth-sources '((:source (:secrets default) :host t :port t :user "joe") +;; (:source (:secrets "session") :host t :port t :user "joe") +;; (:source (:secrets "Login") :host t :port t) +;; )) + +;; (setq auth-sources '((:source "~/.authinfo.gpg" :host t :port t))) + +;; (auth-source-backend-parse "myfile.gpg") +;; (auth-source-backend-parse 'default) +;; (auth-source-backend-parse "secrets:Login") +;; (auth-source-backend-parse 'macos-keychain-internet) +;; (auth-source-backend-parse 'macos-keychain-generic) +;; (auth-source-backend-parse "macos-keychain-internet:/path/here.keychain") +;; (auth-source-backend-parse "macos-keychain-generic:/path/here.keychain") + +(defun auth-source-backend-parse (entry) + "Creates an auth-source-backend from an ENTRY in `auth-sources'." + (auth-source-backend-parse-parameters + entry + (cond + ;; take 'default and recurse to get it as a Secrets API default collection + ;; matching any user, host, and protocol + ((eq entry 'default) + (auth-source-backend-parse '(:source (:secrets default)))) + ;; take secrets:XYZ and recurse to get it as Secrets API collection "XYZ" + ;; matching any user, host, and protocol + ((and (stringp entry) (string-match "^secrets:\\(.+\\)" entry)) + (auth-source-backend-parse `(:source (:secrets ,(match-string 1 entry))))) + + ;; take 'macos-keychain-internet and recurse to get it as a Mac OS + ;; Keychain collection matching any user, host, and protocol + ((eq entry 'macos-keychain-internet) + (auth-source-backend-parse '(:source (:macos-keychain-internet default)))) + ;; take 'macos-keychain-generic and recurse to get it as a Mac OS + ;; Keychain collection matching any user, host, and protocol + ((eq entry 'macos-keychain-generic) + (auth-source-backend-parse '(:source (:macos-keychain-generic default)))) + ;; take macos-keychain-internet:XYZ and recurse to get it as macOS + ;; Keychain "XYZ" matching any user, host, and protocol + ((and (stringp entry) (string-match "^macos-keychain-internet:\\(.+\\)" + entry)) + (auth-source-backend-parse `(:source (:macos-keychain-internet + ,(match-string 1 entry))))) + ;; take macos-keychain-generic:XYZ and recurse to get it as macOS + ;; Keychain "XYZ" matching any user, host, and protocol + ((and (stringp entry) (string-match "^macos-keychain-generic:\\(.+\\)" + entry)) + (auth-source-backend-parse `(:source (:macos-keychain-generic + ,(match-string 1 entry))))) + + ;; take just a file name and recurse to get it as a netrc file + ;; matching any user, host, and protocol + ((stringp entry) + (auth-source-backend-parse `(:source ,entry))) + + ;; a file name with parameters + ((stringp (plist-get entry :source)) + (if (equal (file-name-extension (plist-get entry :source)) "plist") + (auth-source-backend + (plist-get entry :source) + :source (plist-get entry :source) + :type 'plstore + :search-function #'auth-source-plstore-search + :create-function #'auth-source-plstore-create + :data (plstore-open (plist-get entry :source))) + (auth-source-backend + (plist-get entry :source) + :source (plist-get entry :source) + :type 'netrc + :search-function #'auth-source-netrc-search + :create-function #'auth-source-netrc-create))) + + ;; the macOS Keychain + ((and + (not (null (plist-get entry :source))) ; the source must not be nil + (listp (plist-get entry :source)) ; and it must be a list + (or + (plist-get (plist-get entry :source) :macos-keychain-generic) + (plist-get (plist-get entry :source) :macos-keychain-internet))) + + (let* ((source-spec (plist-get entry :source)) + (keychain-generic (plist-get source-spec :macos-keychain-generic)) + (keychain-type (if keychain-generic + 'macos-keychain-generic + 'macos-keychain-internet)) + (source (plist-get source-spec (if keychain-generic + :macos-keychain-generic + :macos-keychain-internet)))) + + (when (symbolp source) + (setq source (symbol-name source))) + + (auth-source-backend + (format "Mac OS Keychain (%s)" source) + :source source + :type keychain-type + :search-function #'auth-source-macos-keychain-search + :create-function #'auth-source-macos-keychain-create))) + + ;; the Secrets API. We require the package, in order to have a + ;; defined value for `secrets-enabled'. + ((and + (not (null (plist-get entry :source))) ; the source must not be nil + (listp (plist-get entry :source)) ; and it must be a list + (require 'secrets nil t) ; and we must load the Secrets API + secrets-enabled) ; and that API must be enabled + + ;; the source is either the :secrets key in ENTRY or + ;; if that's missing or nil, it's "session" + (let ((source (or (plist-get (plist-get entry :source) :secrets) + "session"))) + + ;; if the source is a symbol, we look for the alias named so, + ;; and if that alias is missing, we use "Login" + (when (symbolp source) + (setq source (or (secrets-get-alias (symbol-name source)) + "Login"))) + + (if (featurep 'secrets) + (auth-source-backend + (format "Secrets API (%s)" source) + :source source + :type 'secrets + :search-function #'auth-source-secrets-search + :create-function #'auth-source-secrets-create) + (auth-source-do-warn + "auth-source-backend-parse: no Secrets API, ignoring spec: %S" entry) + (auth-source-backend + (format "Ignored Secrets API (%s)" source) + :source "" + :type 'ignore)))) + + ;; none of them + (t + (auth-source-do-warn + "auth-source-backend-parse: invalid backend spec: %S" entry) + (make-instance 'auth-source-backend + :source "" + :type 'ignore))))) + +(defun auth-source-backend-parse-parameters (entry backend) + "Fills in the extra auth-source-backend parameters of ENTRY. +Using the plist ENTRY, get the :host, :port, and :user search +parameters." + (let ((entry (if (stringp entry) + nil + entry)) + val) + (when (setq val (plist-get entry :host)) + (oset backend host val)) + (when (setq val (plist-get entry :user)) + (oset backend user val)) + (when (setq val (plist-get entry :port)) + (oset backend port val))) + backend) + +;; (mapcar 'auth-source-backend-parse auth-sources) + +(cl-defun auth-source-search (&rest spec + &key max require create delete + &allow-other-keys) + "Search or modify authentication backends according to SPEC. + +This function parses `auth-sources' for matches of the SPEC +plist. It can optionally create or update an authentication +token if requested. A token is just a standard Emacs property +list with a :secret property that can be a function; all the +other properties will always hold scalar values. + +Typically the :secret property, if present, contains a password. + +Common search keys are :max, :host, :port, and :user. In +addition, :create specifies if and how tokens will be created. +Finally, :type can specify which backend types you want to check. + +A string value is always matched literally. A symbol is matched +as its string value, literally. All the SPEC values can be +single values (symbol or string) or lists thereof (in which case +any of the search terms matches). + +:create t means to create a token if possible. + +A new token will be created if no matching tokens were found. +The new token will have only the keys the backend requires. For +the netrc backend, for instance, that's the user, host, and +port keys. + +Here's an example: + +\(let ((auth-source-creation-defaults \\='((user . \"defaultUser\") + (A . \"default A\")))) + (auth-source-search :host \"mine\" :type \\='netrc :max 1 + :P \"pppp\" :Q \"qqqq\" + :create t)) + +which says: + +\"Search for any entry matching host `mine' in backends of type + `netrc', maximum one result. + + Create a new entry if you found none. The netrc backend will + automatically require host, user, and port. The host will be + `mine'. We prompt for the user with default `defaultUser' and + for the port without a default. We will not prompt for A, Q, + or P. The resulting token will only have keys user, host, and + port.\" + +:create \\='(A B C) also means to create a token if possible. + +The behavior is like :create t but if the list contains any +parameter, that parameter will be required in the resulting +token. The value for that parameter will be obtained from the +search parameters or from user input. If any queries are needed, +the alist `auth-source-creation-defaults' will be checked for the +default value. If the user, host, or port are missing, the alist +`auth-source-creation-prompts' will be used to look up the +prompts IN THAT ORDER (so the `user' prompt will be queried first, +then `host', then `port', and finally `secret'). Each prompt string +can use %u, %h, and %p to show the user, host, and port. + +Here's an example: + +\(let ((auth-source-creation-defaults \\='((user . \"defaultUser\") + (A . \"default A\"))) + (auth-source-creation-prompts + \\='((password . \"Enter IMAP password for %h:%p: \")))) + (auth-source-search :host \\='(\"nonesuch\" \"twosuch\") :type \\='netrc :max 1 + :P \"pppp\" :Q \"qqqq\" + :create \\='(A B Q))) + +which says: + +\"Search for any entry matching host `nonesuch' + or `twosuch' in backends of type `netrc', maximum one result. + + Create a new entry if you found none. The netrc backend will + automatically require host, user, and port. The host will be + `nonesuch' and Q will be `qqqq'. We prompt for the password + with the shown prompt. We will not prompt for Q. The resulting + token will have keys user, host, port, A, B, and Q. It will not + have P with any value, even though P is used in the search to + find only entries that have P set to `pppp'.\" + +When multiple values are specified in the search parameter, the +user is prompted for which one. So :host (X Y Z) would ask the +user to choose between X, Y, and Z. + +This creation can fail if the search was not specific enough to +create a new token (it's up to the backend to decide that). You +should `catch' the backend-specific error as usual. Some +backends (netrc, at least) will prompt the user rather than throw +an error. + +:require (A B C) means that only results that contain those +tokens will be returned. Thus for instance requiring :secret +will ensure that any results will actually have a :secret +property. + +:delete t means to delete any found entries. nil by default. +Use `auth-source-delete' in ELisp code instead of calling +`auth-source-search' directly with this parameter. + +:type (X Y Z) will check only those backend types. `netrc' and +`secrets' are the only ones supported right now. + +:max N means to try to return at most N items (defaults to 1). +More than N items may be returned, depending on the search and +the backend. + +When :max is 0 the function will return just t or nil to indicate +if any matches were found. + +:host (X Y Z) means to match only hosts X, Y, or Z according to +the match rules above. Defaults to t. + +:user (X Y Z) means to match only users X, Y, or Z according to +the match rules above. Defaults to t. + +:port (P Q R) means to match only protocols P, Q, or R. +Defaults to t. + +:K (V1 V2 V3) for any other key K will match values V1, V2, or +V3 (note the match rules above). + +The return value is a list with at most :max tokens. Each token +is a plist with keys :backend :host :port :user, plus any other +keys provided by the backend (notably :secret). But note the +exception for :max 0, which see above. + +The token can hold a :save-function key. If you call that, the +user will be prompted to save the data to the backend. You can't +request that this should happen right after creation, because +`auth-source-search' has no way of knowing if the token is +actually useful. So the caller must arrange to call this function. + +The token's :secret key can hold a function. In that case you +must call it to obtain the actual value." + (let* ((backends (mapcar #'auth-source-backend-parse auth-sources)) + (max (or max 1)) + (ignored-keys '(:require :create :delete :max)) + (keys (cl-loop for i below (length spec) by 2 + unless (memq (nth i spec) ignored-keys) + collect (nth i spec))) + (cached (auth-source-remembered-p spec)) + ;; note that we may have cached results but found is still nil + ;; (there were no results from the search) + (found (auth-source-recall spec)) + filtered-backends) + + (if (and cached auth-source-do-cache) + (auth-source-do-debug + "auth-source-search: found %d CACHED results matching %S" + (length found) spec) + + (cl-assert + (or (eq t create) (listp create)) t + "Invalid auth-source :create parameter (must be t or a list): %s %s") + + (cl-assert + (listp require) t + "Invalid auth-source :require parameter (must be a list): %s") + + (setq filtered-backends (copy-sequence backends)) + (dolist (backend backends) + (cl-dolist (key keys) + ;; ignore invalid slots + (condition-case nil + (unless (auth-source-search-collection + (plist-get spec key) + (slot-value backend key)) + (setq filtered-backends (delq backend filtered-backends)) + (cl-return)) + (invalid-slot-name nil)))) + + (auth-source-do-trivia + "auth-source-search: found %d backends matching %S" + (length filtered-backends) spec) + + ;; (debug spec "filtered" filtered-backends) + ;; First go through all the backends without :create, so we can + ;; query them all. + (setq found (auth-source-search-backends filtered-backends + spec + ;; to exit early + max + ;; create is always nil here + nil delete + require)) + + (auth-source-do-debug + "auth-source-search: found %d results (max %d) matching %S" + (length found) max spec) + + ;; If we didn't find anything, then we allow the backend(s) to + ;; create the entries. + (when (and create + (not found)) + (setq found (auth-source-search-backends filtered-backends + spec + ;; to exit early + max + create delete + require)) + (auth-source-do-debug + "auth-source-search: CREATED %d results (max %d) matching %S" + (length found) max spec)) + + ;; note we remember the lack of result too, if it's applicable + (when auth-source-do-cache + (auth-source-remember spec found))) + + (if (zerop max) + (not (null found)) + found))) + +(defun auth-source-search-backends (backends spec max create delete require) + (let ((max (if (zerop max) 1 max)) ; stop with 1 match if we're asked for zero + matches) + (dolist (backend backends) + (when (> max (length matches)) ; if we need more matches... + (let* ((bmatches (apply + (slot-value backend 'search-function) + :backend backend + :type (slot-value backend 'type) + ;; note we're overriding whatever the spec + ;; has for :max, :require, :create, and :delete + :max max + :require require + :create create + :delete delete + spec))) + (when bmatches + (auth-source-do-trivia + "auth-source-search-backend: got %d (max %d) in %s:%s matching %S" + (length bmatches) max + (slot-value backend 'type) + (slot-value backend 'source) + spec) + (setq matches (append matches bmatches)))))) + matches)) + +;; (auth-source-search :max 0) +;; (auth-source-search :max 1) +;; (funcall (plist-get (nth 0 (auth-source-search :max 1)) :secret)) +;; (auth-source-search :host "nonesuch" :type 'netrc :K 1) +;; (auth-source-search :host "nonesuch" :type 'secrets) + +(defun auth-source-delete (&rest spec) + "Delete entries from the authentication backends according to SPEC. +Calls `auth-source-search' with the :delete property in SPEC set to t. +The backend may not actually delete the entries. + +Returns the deleted entries." + (auth-source-search (plist-put spec :delete t))) + +(defun auth-source-search-collection (collection value) + "Returns t is VALUE is t or COLLECTION is t or COLLECTION contains VALUE." + (when (and (atom collection) (not (eq t collection))) + (setq collection (list collection))) + + ;; (debug :collection collection :value value) + (or (eq collection t) + (eq value t) + (equal collection value) + (member value collection))) + +(defvar auth-source-netrc-cache nil) + +(defun auth-source-forget-all-cached () + "Forget all cached auth-source data." + (interactive) + (cl-do-symbols (sym password-data) + ;; when the symbol name starts with auth-source-magic + (when (string-match (concat "^" auth-source-magic) (symbol-name sym)) + ;; remove that key + (password-cache-remove (symbol-name sym)))) + (setq auth-source-netrc-cache nil)) + +(defun auth-source-format-cache-entry (spec) + "Format SPEC entry to put it in the password cache." + (concat auth-source-magic (format "%S" spec))) + +(defun auth-source-remember (spec found) + "Remember FOUND search results for SPEC." + (let ((password-cache-expiry auth-source-cache-expiry)) + (password-cache-add + (auth-source-format-cache-entry spec) found))) + +(defun auth-source-recall (spec) + "Recall FOUND search results for SPEC." + (password-read-from-cache (auth-source-format-cache-entry spec))) + +(defun auth-source-remembered-p (spec) + "Check if SPEC is remembered." + (password-in-cache-p + (auth-source-format-cache-entry spec))) + +(defun auth-source-forget (spec) + "Forget any cached data matching SPEC exactly. + +This is the same SPEC you passed to `auth-source-search'. +Returns t or nil for forgotten or not found." + (password-cache-remove (auth-source-format-cache-entry spec))) + +;; (loop for sym being the symbols of password-data when (string-match (concat "^" auth-source-magic) (symbol-name sym)) collect (symbol-name sym)) + +;; (auth-source-remember '(:host "wedd") '(4 5 6)) +;; (auth-source-remembered-p '(:host "wedd")) +;; (auth-source-remember '(:host "xedd") '(1 2 3)) +;; (auth-source-remembered-p '(:host "xedd")) +;; (auth-source-remembered-p '(:host "zedd")) +;; (auth-source-recall '(:host "xedd")) +;; (auth-source-recall '(:host t)) +;; (auth-source-forget+ :host t) + +(defun auth-source-forget+ (&rest spec) + "Forget any cached data matching SPEC. Returns forgotten count. + +This is not a full `auth-source-search' spec but works similarly. +For instance, \(:host \"myhost\" \"yourhost\") would find all the +cached data that was found with a search for those two hosts, +while \(:host t) would find all host entries." + (let ((count 0) + sname) + (cl-do-symbols (sym password-data) + ;; when the symbol name matches with auth-source-magic + (when (and (setq sname (symbol-name sym)) + (string-match (concat "^" auth-source-magic "\\(.+\\)") + sname) + ;; and the spec matches what was stored in the cache + (auth-source-specmatchp spec (read (match-string 1 sname)))) + ;; remove that key + (password-cache-remove sname) + (cl-incf count))) + count)) + +(defun auth-source-specmatchp (spec stored) + (let ((keys (cl-loop for i below (length spec) by 2 + collect (nth i spec)))) + (not (eq + (cl-dolist (key keys) + (unless (auth-source-search-collection (plist-get stored key) + (plist-get spec key)) + (cl-return 'no))) + 'no)))) + +;; (auth-source-pick-first-password :host "z.lifelogs.com") +;; (auth-source-pick-first-password :port "imap") +(defun auth-source-pick-first-password (&rest spec) + "Pick the first secret found from applying SPEC to `auth-source-search'." + (let* ((result (nth 0 (apply #'auth-source-search (plist-put spec :max 1)))) + (secret (plist-get result :secret))) + + (if (functionp secret) + (funcall secret) + secret))) + +;; (auth-source-format-prompt "test %u %h %p" '((?u "user") (?h "host"))) +(defun auth-source-format-prompt (prompt alist) + "Format PROMPT using %x (for any character x) specifiers in ALIST." + (dolist (cell alist) + (let ((c (nth 0 cell)) + (v (nth 1 cell))) + (when (and c v) + (setq prompt (replace-regexp-in-string (format "%%%c" c) + (format "%s" v) + prompt nil t))))) + prompt) + +(defun auth-source-ensure-strings (values) + (if (eq values t) + values + (unless (listp values) + (setq values (list values))) + (mapcar (lambda (value) + (if (numberp value) + (format "%s" value) + value)) + values))) + +;;; Backend specific parsing: netrc/authinfo backend + +(defun auth-source--aput-1 (alist key val) + (let ((seen ()) + (rest alist)) + (while (and (consp rest) (not (equal key (caar rest)))) + (push (pop rest) seen)) + (cons (cons key val) + (if (null rest) alist + (nconc (nreverse seen) + (if (equal key (caar rest)) (cdr rest) rest)))))) +(defmacro auth-source--aput (var key val) + `(setq ,var (auth-source--aput-1 ,var ,key ,val))) + +(defun auth-source--aget (alist key) + (cdr (assoc key alist))) + +;; (auth-source-netrc-parse :file "~/.authinfo.gpg") +(cl-defun auth-source-netrc-parse (&key file max host user port require + &allow-other-keys) + "Parse FILE and return a list of all entries in the file. +Note that the MAX parameter is used so we can exit the parse early." + (if (listp file) + ;; We got already parsed contents; just return it. + file + (when (file-exists-p file) + (setq port (auth-source-ensure-strings port)) + (with-temp-buffer + (let* ((max (or max 5000)) ; sanity check: default to stop at 5K + (modified 0) + (cached (cdr-safe (assoc file auth-source-netrc-cache))) + (cached-mtime (plist-get cached :mtime)) + (cached-secrets (plist-get cached :secret)) + (check (lambda(alist) + (and alist + (auth-source-search-collection + host + (or + (auth-source--aget alist "machine") + (auth-source--aget alist "host") + t)) + (auth-source-search-collection + user + (or + (auth-source--aget alist "login") + (auth-source--aget alist "account") + (auth-source--aget alist "user") + t)) + (auth-source-search-collection + port + (or + (auth-source--aget alist "port") + (auth-source--aget alist "protocol") + t)) + (or + ;; the required list of keys is nil, or + (null require) + ;; every element of require is in n(ormalized) + (let ((n (nth 0 (auth-source-netrc-normalize + (list alist) file)))) + (cl-loop for req in require + always (plist-get n req))))))) + result) + + (if (and (functionp cached-secrets) + (equal cached-mtime + (nth 5 (file-attributes file)))) + (progn + (auth-source-do-trivia + "auth-source-netrc-parse: using CACHED file data for %s" + file) + (insert (funcall cached-secrets))) + (insert-file-contents file) + ;; cache all netrc files (used to be just .gpg files) + ;; Store the contents of the file heavily encrypted in memory. + ;; (note for the irony-impaired: they are just obfuscated) + (auth-source--aput + auth-source-netrc-cache file + (list :mtime (nth 5 (file-attributes file)) + :secret (let ((v (mapcar #'1+ (buffer-string)))) + (lambda () (apply #'string (mapcar #'1- v))))))) + (goto-char (point-min)) + (let ((entries (auth-source-netrc-parse-entries check max)) + alist) + (while (setq alist (pop entries)) + (push (nreverse alist) result))) + + (when (< 0 modified) + (when auth-source-gpg-encrypt-to + ;; (see bug#7487) making `epa-file-encrypt-to' local to + ;; this buffer lets epa-file skip the key selection query + ;; (see the `local-variable-p' check in + ;; `epa-file-write-region'). + (unless (local-variable-p 'epa-file-encrypt-to (current-buffer)) + (make-local-variable 'epa-file-encrypt-to)) + (if (listp auth-source-gpg-encrypt-to) + (setq epa-file-encrypt-to auth-source-gpg-encrypt-to))) + + ;; ask AFTER we've successfully opened the file + (when (y-or-n-p (format "Save file %s? (%d deletions)" + file modified)) + (write-region (point-min) (point-max) file nil 'silent) + (auth-source-do-debug + "auth-source-netrc-parse: modified %d lines in %s" + modified file))) + + (nreverse result)))))) + +(defun auth-source-netrc-parse-next-interesting () + "Advance to the next interesting position in the current buffer." + ;; If we're looking at a comment or are at the end of the line, move forward + (while (or (looking-at "#") + (and (eolp) + (not (eobp)))) + (forward-line 1)) + (skip-chars-forward "\t ")) + +(defun auth-source-netrc-parse-one () + "Read one thing from the current buffer." + (auth-source-netrc-parse-next-interesting) + + (when (or (looking-at "'\\([^']*\\)'") + (looking-at "\"\\([^\"]*\\)\"") + (looking-at "\\([^ \t\n]+\\)")) + (forward-char (length (match-string 0))) + (auth-source-netrc-parse-next-interesting) + (match-string-no-properties 1))) + +;; with thanks to org-mode +(defsubst auth-source-current-line (&optional pos) + (save-excursion + (and pos (goto-char pos)) + ;; works also in narrowed buffer, because we start at 1, not point-min + (+ (if (bolp) 1 0) (count-lines 1 (point))))) + +(defun auth-source-netrc-parse-entries(check max) + "Parse up to MAX netrc entries, passed by CHECK, from the current buffer." + (let ((adder (lambda(check alist all) + (when (and + alist + (> max (length all)) + (funcall check alist)) + (push alist all)) + all)) + item item2 all alist default) + (while (setq item (auth-source-netrc-parse-one)) + (setq default (equal item "default")) + ;; We're starting a new machine. Save the old one. + (when (and alist + (or default + (equal item "machine"))) + ;; (auth-source-do-trivia + ;; "auth-source-netrc-parse-entries: got entry %S" alist) + (setq all (funcall adder check alist all) + alist nil)) + ;; In default entries, we don't have a next token. + ;; We store them as ("machine" . t) + (if default + (push (cons "machine" t) alist) + ;; Not a default entry. Grab the next item. + (when (setq item2 (auth-source-netrc-parse-one)) + ;; Did we get a "machine" value? + (if (equal item2 "machine") + (error + "%s: Unexpected `machine' token at line %d" + "auth-source-netrc-parse-entries" + (auth-source-current-line)) + (push (cons item item2) alist))))) + + ;; Clean up: if there's an entry left over, use it. + (when alist + (setq all (funcall adder check alist all)) + ;; (auth-source-do-trivia + ;; "auth-source-netrc-parse-entries: got2 entry %S" alist) + ) + (nreverse all))) + +(defvar auth-source-passphrase-alist nil) + +(defun auth-source-token-passphrase-callback-function (_context _key-id file) + (let* ((file (file-truename file)) + (entry (assoc file auth-source-passphrase-alist)) + passphrase) + ;; return the saved passphrase, calling a function if needed + (or (copy-sequence (if (functionp (cdr entry)) + (funcall (cdr entry)) + (cdr entry))) + (progn + (unless entry + (setq entry (list file)) + (push entry auth-source-passphrase-alist)) + (setq passphrase + (read-passwd + (format "Passphrase for %s tokens: " file) + t)) + (setcdr entry (let ((p (copy-sequence passphrase))) + (lambda () p))) + passphrase)))) + +;; (auth-source-epa-extract-gpg-token "gpg:LS0tLS1CRUdJTiBQR1AgTUVTU0FHRS0tLS0tClZlcnNpb246IEdudVBHIHYxLjQuMTEgKEdOVS9MaW51eCkKCmpBMEVBd01DT25qMjB1ak9rZnRneVI3K21iNm9aZWhuLzRad3cySkdlbnVaKzRpeEswWDY5di9icDI1U1dsQT0KPS9yc2wKLS0tLS1FTkQgUEdQIE1FU1NBR0UtLS0tLQo=" "~/.netrc") +(defun auth-source-epa-extract-gpg-token (secret file) + "Pass either the decoded SECRET or the gpg:BASE64DATA version. +FILE is the file from which we obtained this token." + (when (string-match "^gpg:\\(.+\\)" secret) + (setq secret (base64-decode-string (match-string 1 secret)))) + (let ((context (epg-make-context 'OpenPGP))) + (epg-context-set-passphrase-callback + context + (cons #'auth-source-token-passphrase-callback-function + file)) + (epg-decrypt-string context secret))) + +(defvar pp-escape-newlines) + +;; (insert (auth-source-epa-make-gpg-token "mysecret" "~/.netrc")) +(defun auth-source-epa-make-gpg-token (secret file) + (let ((context (epg-make-context 'OpenPGP)) + (pp-escape-newlines nil) + cipher) + (setf (epg-context-armor context) t) + (epg-context-set-passphrase-callback + context + (cons #'auth-source-token-passphrase-callback-function + file)) + (setq cipher (epg-encrypt-string context secret nil)) + (with-temp-buffer + (insert cipher) + (base64-encode-region (point-min) (point-max) t) + (concat "gpg:" (buffer-substring-no-properties + (point-min) + (point-max)))))) + +(defun auth-source--symbol-keyword (symbol) + (intern (format ":%s" symbol))) + +(defun auth-source-netrc-normalize (alist filename) + (mapcar (lambda (entry) + (let (ret item) + (while (setq item (pop entry)) + (let ((k (car item)) + (v (cdr item))) + + ;; apply key aliases + (setq k (cond ((member k '("machine")) "host") + ((member k '("login" "account")) "user") + ((member k '("protocol")) "port") + ((member k '("password")) "secret") + (t k))) + + ;; send back the secret in a function (lexical binding) + (when (equal k "secret") + (setq v (let ((lexv v) + (token-decoder nil)) + (when (string-match "^gpg:" lexv) + ;; it's a GPG token: create a token decoder + ;; which unsets itself once + (setq token-decoder + (lambda (val) + (prog1 + (auth-source-epa-extract-gpg-token + val + filename) + (setq token-decoder nil))))) + (lambda () + (when token-decoder + (setq lexv (funcall token-decoder lexv))) + lexv)))) + (setq ret (plist-put ret + (auth-source--symbol-keyword k) + v)))) + ret)) + alist)) + +;; (setq secret (plist-get (nth 0 (auth-source-search :host t :type 'netrc :K 1 :max 1)) :secret)) +;; (funcall secret) + +(cl-defun auth-source-netrc-search (&rest spec + &key backend require create + type max host user port + &allow-other-keys) + "Given a property list SPEC, return search matches from the :backend. +See `auth-source-search' for details on SPEC." + ;; just in case, check that the type is correct (null or same as the backend) + (cl-assert (or (null type) (eq type (oref backend type))) + t "Invalid netrc search: %s %s") + + (let ((results (auth-source-netrc-normalize + (auth-source-netrc-parse + :max max + :require require + :file (oref backend source) + :host (or host t) + :user (or user t) + :port (or port t)) + (oref backend source)))) + + ;; if we need to create an entry AND none were found to match + (when (and create + (not results)) + + ;; create based on the spec and record the value + (setq results (or + ;; if the user did not want to create the entry + ;; in the file, it will be returned + (apply (slot-value backend 'create-function) spec) + ;; if not, we do the search again without :create + ;; to get the updated data. + + ;; the result will be returned, even if the search fails + (apply #'auth-source-netrc-search + (plist-put spec :create nil))))) + results)) + +(defun auth-source-netrc-element-or-first (v) + (if (listp v) + (nth 0 v) + v)) + +;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t) +;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t :create-extra-keys '((A "default A") (B))) + +(cl-defun auth-source-netrc-create (&rest spec + &key backend host port create + &allow-other-keys) + (let* ((base-required '(host user port secret)) + ;; we know (because of an assertion in auth-source-search) that the + ;; :create parameter is either t or a list (which includes nil) + (create-extra (if (eq t create) nil create)) + (current-data (car (auth-source-search :max 1 + :host host + :port port))) + (required (append base-required create-extra)) + (file (oref backend source)) + (add "") + ;; `valist' is an alist + valist + ;; `artificial' will be returned if no creation is needed + artificial) + + ;; only for base required elements (defined as function parameters): + ;; fill in the valist with whatever data we may have from the search + ;; we complete the first value if it's a list and use the value otherwise + (dolist (br base-required) + (let ((val (plist-get spec (auth-source--symbol-keyword br)))) + (when val + (let ((br-choice (cond + ;; all-accepting choice (predicate is t) + ((eq t val) nil) + ;; just the value otherwise + (t val)))) + (when br-choice + (auth-source--aput valist br br-choice)))))) + + ;; for extra required elements, see if the spec includes a value for them + (dolist (er create-extra) + (let ((k (auth-source--symbol-keyword er)) + (keys (cl-loop for i below (length spec) by 2 + collect (nth i spec)))) + (when (memq k keys) + (auth-source--aput valist er (plist-get spec k))))) + + ;; for each required element + (dolist (r required) + (let* ((data (auth-source--aget valist r)) + ;; take the first element if the data is a list + (data (or (auth-source-netrc-element-or-first data) + (plist-get current-data + (auth-source--symbol-keyword r)))) + ;; this is the default to be offered + (given-default (auth-source--aget + auth-source-creation-defaults r)) + ;; the default supplementals are simple: + ;; for the user, try `given-default' and then (user-login-name); + ;; otherwise take `given-default' + (default (cond + ((and (not given-default) (eq r 'user)) + (user-login-name)) + (t given-default))) + (printable-defaults (list + (cons 'user + (or + (auth-source-netrc-element-or-first + (auth-source--aget valist 'user)) + (plist-get artificial :user) + "[any user]")) + (cons 'host + (or + (auth-source-netrc-element-or-first + (auth-source--aget valist 'host)) + (plist-get artificial :host) + "[any host]")) + (cons 'port + (or + (auth-source-netrc-element-or-first + (auth-source--aget valist 'port)) + (plist-get artificial :port) + "[any port]")))) + (prompt (or (auth-source--aget auth-source-creation-prompts r) + (cl-case r + (secret "%p password for %u@%h: ") + (user "%p user name for %h: ") + (host "%p host name for user %u: ") + (port "%p port for %u@%h: ")) + (format "Enter %s (%%u@%%h:%%p): " r))) + (prompt (auth-source-format-prompt + prompt + `((?u ,(auth-source--aget printable-defaults 'user)) + (?h ,(auth-source--aget printable-defaults 'host)) + (?p ,(auth-source--aget printable-defaults 'port)))))) + + ;; Store the data, prompting for the password if needed. + (setq data (or data + (if (eq r 'secret) + ;; Special case prompt for passwords. + ;; TODO: make the default (setq auth-source-netrc-use-gpg-tokens `((,(if (boundp 'epa-file-auto-mode-alist-entry) (car epa-file-auto-mode-alist-entry) "\\.gpg\\'") nil) (t gpg))) + ;; TODO: or maybe leave as (setq auth-source-netrc-use-gpg-tokens 'never) + (let* ((ep (format "Use GPG password tokens in %s?" file)) + (gpg-encrypt + (cond + ((eq auth-source-netrc-use-gpg-tokens 'never) + 'never) + ((listp auth-source-netrc-use-gpg-tokens) + (let ((check (copy-sequence + auth-source-netrc-use-gpg-tokens)) + item ret) + (while check + (setq item (pop check)) + (when (or (eq (car item) t) + (string-match (car item) file)) + (setq ret (cdr item)) + (setq check nil))) + ;; FIXME: `ret' unused. + ;; Should we return it here? + )) + (t 'never))) + (plain (or (eval default) (read-passwd prompt)))) + ;; ask if we don't know what to do (in which case + ;; auth-source-netrc-use-gpg-tokens must be a list) + (unless gpg-encrypt + (setq gpg-encrypt (if (y-or-n-p ep) 'gpg 'never)) + ;; TODO: save the defcustom now? or ask? + (setq auth-source-netrc-use-gpg-tokens + (cons `(,file ,gpg-encrypt) + auth-source-netrc-use-gpg-tokens))) + (if (eq gpg-encrypt 'gpg) + (auth-source-epa-make-gpg-token plain file) + plain)) + (if (stringp default) + (read-string (if (string-match ": *\\'" prompt) + (concat (substring prompt 0 (match-beginning 0)) + " (default " default "): ") + (concat prompt "(default " default ") ")) + nil nil default) + (eval default))))) + + (when data + (setq artificial (plist-put artificial + (auth-source--symbol-keyword r) + (if (eq r 'secret) + (let ((data data)) + (lambda () data)) + data)))) + + ;; When r is not an empty string... + (when (and (stringp data) + (< 0 (length data))) + ;; this function is not strictly necessary but I think it + ;; makes the code clearer -tzz + (let ((printer (lambda () + ;; append the key (the symbol name of r) + ;; and the value in r + (format "%s%s %s" + ;; prepend a space + (if (zerop (length add)) "" " ") + ;; remap auth-source tokens to netrc + (cl-case r + (user "login") + (host "machine") + (secret "password") + (port "port") ; redundant but clearer + (t (symbol-name r))) + (if (string-match "[\"# ]" data) + (format "%S" data) + data))))) + (setq add (concat add (funcall printer))))))) + + (plist-put + artificial + :save-function + (let ((file file) + (add add)) + (lambda () (auth-source-netrc-saver file add)))) + + (list artificial))) + +;;(funcall (plist-get (nth 0 (auth-source-search :host '("nonesuch2") :user "tzz" :port "imap" :create t :max 1)) :save-function)) +(defun auth-source-netrc-saver (file add) + "Save a line ADD in FILE, prompting along the way. +Respects `auth-source-save-behavior'. Uses +`auth-source-netrc-cache' to avoid prompting more than once." + (let* ((key (format "%s %s" file (rfc2104-hash 'md5 64 16 file add))) + (cached (assoc key auth-source-netrc-cache))) + + (if cached + (auth-source-do-trivia + "auth-source-netrc-saver: found previous run for key %s, returning" + key) + (with-temp-buffer + (when (file-exists-p file) + (insert-file-contents file)) + (when auth-source-gpg-encrypt-to + ;; (see bug#7487) making `epa-file-encrypt-to' local to + ;; this buffer lets epa-file skip the key selection query + ;; (see the `local-variable-p' check in + ;; `epa-file-write-region'). + (unless (local-variable-p 'epa-file-encrypt-to (current-buffer)) + (make-local-variable 'epa-file-encrypt-to)) + (if (listp auth-source-gpg-encrypt-to) + (setq epa-file-encrypt-to auth-source-gpg-encrypt-to))) + ;; we want the new data to be found first, so insert at beginning + (goto-char (point-min)) + + ;; Ask AFTER we've successfully opened the file. + (let ((prompt (format "Save auth info to file %s? " file)) + (done (not (eq auth-source-save-behavior 'ask))) + (bufname "*auth-source Help*") + k) + (while (not done) + (setq k (auth-source-read-char-choice prompt '(?y ?n ?N ?e ??))) + (cl-case k + (?y (setq done t)) + (?? (save-excursion + (with-output-to-temp-buffer bufname + (princ + (concat "(y)es, save\n" + "(n)o but use the info\n" + "(N)o and don't ask to save again\n" + "(e)dit the line\n" + "(?) for help as you can see.\n")) + ;; Why? Doesn't with-output-to-temp-buffer already do + ;; the exact same thing anyway? --Stef + (set-buffer standard-output) + (help-mode)))) + (?n (setq add "" + done t)) + (?N + (setq add "" + done t) + (customize-save-variable 'auth-source-save-behavior nil)) + (?e (setq add (read-string "Line to add: " add))) + (t nil))) + + (when (get-buffer-window bufname) + (delete-window (get-buffer-window bufname))) + + ;; Make sure the info is not saved. + (when (null auth-source-save-behavior) + (setq add "")) + + (when (< 0 (length add)) + (progn + (unless (bolp) + (insert "\n")) + (insert add "\n") + (write-region (point-min) (point-max) file nil 'silent) + ;; Make the .authinfo file non-world-readable. + (set-file-modes file #o600) + (auth-source-do-debug + "auth-source-netrc-create: wrote 1 new line to %s" + file) + (message "Saved new authentication information to %s" file) + nil)))) + (auth-source--aput auth-source-netrc-cache key "ran")))) + +;;; Backend specific parsing: Secrets API backend + +;; (let ((auth-sources '(default))) (auth-source-search :max 1 :create t)) +;; (let ((auth-sources '(default))) (auth-source-search :max 1 :delete t)) +;; (let ((auth-sources '(default))) (auth-source-search :max 1)) +;; (let ((auth-sources '(default))) (auth-source-search)) +;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1)) +;; (let ((auth-sources '("secrets:Login"))) (auth-source-search :max 1 :signon_realm "https://git.gnus.org/Git")) + +(defun auth-source-secrets-listify-pattern (pattern) + "Convert a pattern with lists to a list of string patterns. + +auth-source patterns can have values of the form :foo (\"bar\" +\"qux\"), which means to match any secret with :foo equal to +\"bar\" or :foo equal to \"qux\". The secrets backend supports +only string values for patterns, so this routine returns a list +of patterns that is equivalent to the single original pattern +when interpreted such that if a secret matches any pattern in the +list, it matches the original pattern." + (if (null pattern) + '(nil) + (let* ((key (pop pattern)) + (value (pop pattern)) + (tails (auth-source-secrets-listify-pattern pattern)) + (heads (if (stringp value) + (list (list key value)) + (mapcar (lambda (v) (list key v)) value)))) + (cl-loop for h in heads + nconc (cl-loop for tl in tails collect (append h tl)))))) + +(cl-defun auth-source-secrets-search (&rest spec + &key backend create delete label max + &allow-other-keys) + "Search the Secrets API; spec is like `auth-source'. + +The :label key specifies the item's label. It is the only key +that can specify a substring. Any :label value besides a string +will allow any label. + +All other search keys must match exactly. If you need substring +matching, do a wider search and narrow it down yourself. + +You'll get back all the properties of the token as a plist. + +Here's an example that looks for the first item in the `Login' +Secrets collection: + + (let ((auth-sources \\='(\"secrets:Login\"))) + (auth-source-search :max 1) + +Here's another that looks for the first item in the `Login' +Secrets collection whose label contains `gnus': + + (let ((auth-sources \\='(\"secrets:Login\"))) + (auth-source-search :max 1 :label \"gnus\") + +And this one looks for the first item in the `Login' Secrets +collection that's a Google Chrome entry for the git.gnus.org site +authentication tokens: + + (let ((auth-sources \\='(\"secrets:Login\"))) + (auth-source-search :max 1 :signon_realm \"https://git.gnus.org/Git\")) +" + + ;; TODO + (cl-assert (not create) nil + "The Secrets API auth-source backend doesn't support creation yet") + ;; TODO + ;; (secrets-delete-item coll elt) + (cl-assert (not delete) nil + "The Secrets API auth-source backend doesn't support deletion yet") + + (let* ((coll (oref backend source)) + (max (or max 5000)) ; sanity check: default to stop at 5K + (ignored-keys '(:create :delete :max :backend :label :require :type)) + (search-keys (cl-loop for i below (length spec) by 2 + unless (memq (nth i spec) ignored-keys) + collect (nth i spec))) + ;; build a search spec without the ignored keys + ;; if a search key is nil or t (match anything), we skip it + (search-specs (auth-source-secrets-listify-pattern + (apply #'append (mapcar + (lambda (k) + (if (or (null (plist-get spec k)) + (eq t (plist-get spec k))) + nil + (list k (plist-get spec k)))) + search-keys)))) + ;; needed keys (always including host, login, port, and secret) + (returned-keys (delete-dups (append + '(:host :login :port :secret) + search-keys))) + (items + (cl-loop + for search-spec in search-specs + nconc + (cl-loop for item in (apply #'secrets-search-items coll search-spec) + unless (and (stringp label) + (not (string-match label item))) + collect item))) + ;; TODO: respect max in `secrets-search-items', not after the fact + (items (butlast items (- (length items) max))) + ;; convert the item name to a full plist + (items (mapcar (lambda (item) + (append + ;; make an entry for the secret (password) element + (list + :secret + (let ((v (secrets-get-secret coll item))) + (lambda () v))) + ;; rewrite the entry from ((k1 v1) (k2 v2)) to plist + (apply #'append + (mapcar (lambda (entry) + (list (car entry) (cdr entry))) + (secrets-get-attributes coll item))))) + items)) + ;; ensure each item has each key in `returned-keys' + (items (mapcar (lambda (plist) + (append + (apply #'append + (mapcar (lambda (req) + (if (plist-get plist req) + nil + (list req nil))) + returned-keys)) + plist)) + items))) + items)) + +(defun auth-source-secrets-create (&rest spec) + ;; TODO + ;; (apply 'secrets-create-item (auth-get-source entry) name passwd spec) + (debug spec)) + +;;; Backend specific parsing: Mac OS Keychain (using /usr/bin/security) backend + +;; (let ((auth-sources '(macos-keychain-internet))) (auth-source-search :max 1 :create t)) +;; (let ((auth-sources '(macos-keychain-internet))) (auth-source-search :max 1 :delete t)) +;; (let ((auth-sources '(macos-keychain-internet))) (auth-source-search :max 1)) +;; (let ((auth-sources '(macos-keychain-internet))) (auth-source-search)) + +;; (let ((auth-sources '(macos-keychain-generic))) (auth-source-search :max 1 :create t)) +;; (let ((auth-sources '(macos-keychain-generic))) (auth-source-search :max 1 :delete t)) +;; (let ((auth-sources '(macos-keychain-generic))) (auth-source-search :max 1)) +;; (let ((auth-sources '(macos-keychain-generic))) (auth-source-search)) + +;; (let ((auth-sources '("macos-keychain-internet:/Users/tzz/Library/Keychains/login.keychain"))) (auth-source-search :max 1)) +;; (let ((auth-sources '("macos-keychain-generic:Login"))) (auth-source-search :max 1 :host "git.gnus.org")) +;; (let ((auth-sources '("macos-keychain-generic:Login"))) (auth-source-search :max 1)) + +(cl-defun auth-source-macos-keychain-search (&rest spec + &key backend create delete type max + &allow-other-keys) + "Search the macOS Keychain; spec is like `auth-source'. + +All search keys must match exactly. If you need substring +matching, do a wider search and narrow it down yourself. + +You'll get back all the properties of the token as a plist. + +The :type key is either `macos-keychain-internet' or +`macos-keychain-generic'. + +For the internet keychain type, the :label key searches the +item's labels (\"-l LABEL\" passed to \"/usr/bin/security\"). +Similarly, :host maps to \"-s HOST\", :user maps to \"-a USER\", +and :port maps to \"-P PORT\" or \"-r PROT\" +\(note PROT has to be a 4-character string). + +For the generic keychain type, the :label key searches the item's +labels (\"-l LABEL\" passed to \"/usr/bin/security\"). +Similarly, :host maps to \"-c HOST\" (the \"creator\" keychain +field), :user maps to \"-a USER\", and :port maps to \"-s PORT\". + +Here's an example that looks for the first item in the default +generic macOS Keychain: + + (let ((auth-sources \\='(macos-keychain-generic))) + (auth-source-search :max 1) + +Here's another that looks for the first item in the internet +macOS Keychain collection whose label is `gnus': + + (let ((auth-sources \\='(macos-keychain-internet))) + (auth-source-search :max 1 :label \"gnus\") + +And this one looks for the first item in the internet keychain +entries for git.gnus.org: + + (let ((auth-sources \\='(macos-keychain-internet\"))) + (auth-source-search :max 1 :host \"git.gnus.org\")) +" + ;; TODO + (cl-assert (not create) nil + "The macOS Keychain auth-source backend doesn't support creation yet") + ;; TODO + ;; (macos-keychain-delete-item coll elt) + (cl-assert (not delete) nil + "The macOS Keychain auth-source backend doesn't support deletion yet") + + (let* ((coll (oref backend source)) + (max (or max 5000)) ; sanity check: default to stop at 5K + ;; Filter out ignored keys from the spec + (ignored-keys '(:create :delete :max :backend :label :host :port)) + ;; Build a search spec without the ignored keys + ;; FIXME make this loop a function? it's used in at least 3 places + (search-keys (cl-loop for i below (length spec) by 2 + unless (memq (nth i spec) ignored-keys) + collect (nth i spec))) + ;; If a search key value is nil or t (match anything), we skip it + (search-spec (apply #'append (mapcar + (lambda (k) + (if (or (null (plist-get spec k)) + (eq t (plist-get spec k))) + nil + (list k (plist-get spec k)))) + search-keys))) + ;; needed keys (always including host, login, port, and secret) + (returned-keys (delete-dups (append + '(:host :login :port :secret) + search-keys))) + ;; Extract host and port from spec + (hosts (plist-get spec :host)) + (hosts (if (and hosts (listp hosts)) hosts `(,hosts))) + (ports (plist-get spec :port)) + (ports (if (and ports (listp ports)) ports `(,ports))) + ;; Loop through all combinations of host/port and pass each of these to + ;; auth-source-macos-keychain-search-items + (items (catch 'match + (dolist (host hosts) + (dolist (port ports) + (let* ((port (if port (format "%S" port))) + (items (apply #'auth-source-macos-keychain-search-items + coll + type + max + host port + search-spec))) + (when items + (throw 'match items))))))) + + ;; ensure each item has each key in `returned-keys' + (items (mapcar (lambda (plist) + (append + (apply #'append + (mapcar (lambda (req) + (if (plist-get plist req) + nil + (list req nil))) + returned-keys)) + plist)) + items))) + items)) + + +(defun auth-source--decode-octal-string (string) + "Convert octal string to utf-8 string. E.g: 'a\134b' to 'a\b'" + (let ((list (string-to-list string)) + (size (length string))) + (decode-coding-string + (apply #'unibyte-string + (cl-loop for i = 0 then (+ i (if (eq (nth i list) ?\\) 4 1)) + for var = (nth i list) + while (< i size) + if (eq var ?\\) + collect (string-to-number + (concat (cl-subseq list (+ i 1) (+ i 4))) 8) + else + collect var)) + 'utf-8))) + +(cl-defun auth-source-macos-keychain-search-items (coll _type _max host port + &key label type user + &allow-other-keys) + (let* ((keychain-generic (eq type 'macos-keychain-generic)) + (args `(,(if keychain-generic + "find-generic-password" + "find-internet-password") + "-g")) + (ret (list :type type))) + (when label + (setq args (append args (list "-l" label)))) + (when host + (setq args (append args (list (if keychain-generic "-c" "-s") host)))) + (when user + (setq args (append args (list "-a" user)))) + + (when port + (if keychain-generic + (setq args (append args (list "-s" port))) + (setq args (append args (list + (if (string-match "[0-9]+" port) "-P" "-r") + port))))) + + (unless (equal coll "default") + (setq args (append args (list coll)))) + + (with-temp-buffer + (apply #'call-process "/usr/bin/security" nil t nil args) + (goto-char (point-min)) + (while (not (eobp)) + (cond + ((looking-at "^password: \\(?:0x[0-9A-F]+\\)? *\"\\(.+\\)\"") + (setq ret (auth-source-macos-keychain-result-append + ret + keychain-generic + "secret" + (let ((v (auth-source--decode-octal-string + (match-string 1)))) + (lambda () v))))) + ;; TODO: check if this is really the label + ;; match 0x00000007 ="AppleID" + ((looking-at + "^[ ]+0x00000007 =\\(?:0x[0-9A-F]+\\)? *\"\\(.+\\)\"") + (setq ret (auth-source-macos-keychain-result-append + ret + keychain-generic + "label" + (auth-source--decode-octal-string (match-string 1))))) + ;; match "crtr"="aapl" + ;; match "svce"="AppleID" + ((looking-at + "^[ ]+\"\\([a-z]+\\)\"[^=]+=\\(?:0x[0-9A-F]+\\)? *\"\\(.+\\)\"") + (setq ret (auth-source-macos-keychain-result-append + ret + keychain-generic + (auth-source--decode-octal-string (match-string 1)) + (auth-source--decode-octal-string (match-string 2)))))) + (forward-line))) + ;; return `ret' iff it has the :secret key + (and (plist-get ret :secret) (list ret)))) + +(defun auth-source-macos-keychain-result-append (result generic k v) + (push v result) + (push (auth-source--symbol-keyword + (cond + ((equal k "acct") "user") + ;; for generic keychains, creator is host, service is port + ((and generic (equal k "crtr")) "host") + ((and generic (equal k "svce")) "port") + ;; for internet keychains, protocol is port, server is host + ((and (not generic) (equal k "ptcl")) "port") + ((and (not generic) (equal k "srvr")) "host") + (t k))) + result)) + +(defun auth-source-macos-keychain-create (&rest spec) + ;; TODO + (debug spec)) + +;;; Backend specific parsing: PLSTORE backend + +(cl-defun auth-source-plstore-search (&rest spec + &key backend create delete max + &allow-other-keys) + "Search the PLSTORE; spec is like `auth-source'." + (let* ((store (oref backend data)) + (max (or max 5000)) ; sanity check: default to stop at 5K + (ignored-keys '(:create :delete :max :backend :label :require :type)) + (search-keys (cl-loop for i below (length spec) by 2 + unless (memq (nth i spec) ignored-keys) + collect (nth i spec))) + ;; build a search spec without the ignored keys + ;; if a search key is nil or t (match anything), we skip it + (search-spec (apply #'append (mapcar + (lambda (k) + (let ((v (plist-get spec k))) + (if (or (null v) + (eq t v)) + nil + (if (stringp v) + (setq v (list v))) + (list k v)))) + search-keys))) + ;; needed keys (always including host, login, port, and secret) + (returned-keys (delete-dups (append + '(:host :login :port :secret) + search-keys))) + (items (plstore-find store search-spec)) + (item-names (mapcar #'car items)) + (items (butlast items (- (length items) max))) + ;; convert the item to a full plist + (items (mapcar (lambda (item) + (let* ((plist (copy-tree (cdr item))) + (secret (plist-member plist :secret))) + (if secret + (setcar + (cdr secret) + (let ((v (car (cdr secret)))) + (lambda () v)))) + plist)) + items)) + ;; ensure each item has each key in `returned-keys' + (items (mapcar (lambda (plist) + (append + (apply #'append + (mapcar (lambda (req) + (if (plist-get plist req) + nil + (list req nil))) + returned-keys)) + plist)) + items))) + (cond + ;; if we need to create an entry AND none were found to match + ((and create + (not items)) + + ;; create based on the spec and record the value + (setq items (or + ;; if the user did not want to create the entry + ;; in the file, it will be returned + (apply (slot-value backend 'create-function) spec) + ;; if not, we do the search again without :create + ;; to get the updated data. + + ;; the result will be returned, even if the search fails + (apply #'auth-source-plstore-search + (plist-put spec :create nil))))) + ((and delete + item-names) + (dolist (item-name item-names) + (plstore-delete store item-name)) + (plstore-save store))) + items)) + +(cl-defun auth-source-plstore-create (&rest spec + &key backend host port create + &allow-other-keys) + (let* ((base-required '(host user port secret)) + (base-secret '(secret)) + ;; we know (because of an assertion in auth-source-search) that the + ;; :create parameter is either t or a list (which includes nil) + (create-extra (if (eq t create) nil create)) + (current-data (car (auth-source-search :max 1 + :host host + :port port))) + (required (append base-required create-extra)) + ;; `valist' is an alist + valist + ;; `artificial' will be returned if no creation is needed + artificial + secret-artificial) + + ;; only for base required elements (defined as function parameters): + ;; fill in the valist with whatever data we may have from the search + ;; we complete the first value if it's a list and use the value otherwise + (dolist (br base-required) + (let ((val (plist-get spec (auth-source--symbol-keyword br)))) + (when val + (let ((br-choice (cond + ;; all-accepting choice (predicate is t) + ((eq t val) nil) + ;; just the value otherwise + (t val)))) + (when br-choice + (auth-source--aput valist br br-choice)))))) + + ;; for extra required elements, see if the spec includes a value for them + (dolist (er create-extra) + (let ((k (auth-source--symbol-keyword er)) + (keys (cl-loop for i below (length spec) by 2 + collect (nth i spec)))) + (when (memq k keys) + (auth-source--aput valist er (plist-get spec k))))) + + ;; for each required element + (dolist (r required) + (let* ((data (auth-source--aget valist r)) + ;; take the first element if the data is a list + (data (or (auth-source-netrc-element-or-first data) + (plist-get current-data + (auth-source--symbol-keyword r)))) + ;; this is the default to be offered + (given-default (auth-source--aget + auth-source-creation-defaults r)) + ;; the default supplementals are simple: + ;; for the user, try `given-default' and then (user-login-name); + ;; otherwise take `given-default' + (default (cond + ((and (not given-default) (eq r 'user)) + (user-login-name)) + (t given-default))) + (printable-defaults (list + (cons 'user + (or + (auth-source-netrc-element-or-first + (auth-source--aget valist 'user)) + (plist-get artificial :user) + "[any user]")) + (cons 'host + (or + (auth-source-netrc-element-or-first + (auth-source--aget valist 'host)) + (plist-get artificial :host) + "[any host]")) + (cons 'port + (or + (auth-source-netrc-element-or-first + (auth-source--aget valist 'port)) + (plist-get artificial :port) + "[any port]")))) + (prompt (or (auth-source--aget auth-source-creation-prompts r) + (cl-case r + (secret "%p password for %u@%h: ") + (user "%p user name for %h: ") + (host "%p host name for user %u: ") + (port "%p port for %u@%h: ")) + (format "Enter %s (%%u@%%h:%%p): " r))) + (prompt (auth-source-format-prompt + prompt + `((?u ,(auth-source--aget printable-defaults 'user)) + (?h ,(auth-source--aget printable-defaults 'host)) + (?p ,(auth-source--aget printable-defaults 'port)))))) + + ;; Store the data, prompting for the password if needed. + (setq data (or data + (if (eq r 'secret) + (or (eval default) (read-passwd prompt)) + (if (stringp default) + (read-string + (if (string-match ": *\\'" prompt) + (concat (substring prompt 0 (match-beginning 0)) + " (default " default "): ") + (concat prompt "(default " default ") ")) + nil nil default) + (eval default))))) + + (when data + (if (member r base-secret) + (setq secret-artificial + (plist-put secret-artificial + (auth-source--symbol-keyword r) + data)) + (setq artificial (plist-put artificial + (auth-source--symbol-keyword r) + data)))))) + (plstore-put (oref backend data) + (sha1 (format "%s@%s:%s" + (plist-get artificial :user) + (plist-get artificial :host) + (plist-get artificial :port))) + artificial secret-artificial) + (if (y-or-n-p (format "Save auth info to file %s? " + (plstore-get-file (oref backend data)))) + (plstore-save (oref backend data))))) + +;;; older API + +;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" t "tzz") + +;; deprecate the old interface +(make-obsolete 'auth-source-user-or-password + 'auth-source-search "Emacs 24.1") +(make-obsolete 'auth-source-forget-user-or-password + 'auth-source-forget "Emacs 24.1") + +(defun auth-source-user-or-password + (mode host port &optional username create-missing delete-existing) + "Find MODE (string or list of strings) matching HOST and PORT. + +DEPRECATED in favor of `auth-source-search'! + +USERNAME is optional and will be used as \"login\" in a search +across the Secret Service API (see secrets.el) if the resulting +items don't have a username. This means that if you search for +username \"joe\" and it matches an item but the item doesn't have +a :user attribute, the username \"joe\" will be returned. + +A non nil DELETE-EXISTING means deleting any matching password +entry in the respective sources. This is useful only when +CREATE-MISSING is non nil as well; the intended use case is to +remove wrong password entries. + +If no matching entry is found, and CREATE-MISSING is non nil, +the password will be retrieved interactively, and it will be +stored in the password database which matches best (see +`auth-sources'). + +MODE can be \"login\" or \"password\"." + (auth-source-do-debug + "auth-source-user-or-password: DEPRECATED get %s for %s (%s) + user=%s" + mode host port username) + + (let* ((listy (listp mode)) + (mode (if listy mode (list mode))) + ;; (cname (if username + ;; (format "%s %s:%s %s" mode host port username) + ;; (format "%s %s:%s" mode host port))) + (search (list :host host :port port)) + (search (if username (append search (list :user username)) search)) + (search (if create-missing + (append search (list :create t)) + search)) + (search (if delete-existing + (append search (list :delete t)) + search)) + ;; (found (if (not delete-existing) + ;; (gethash cname auth-source-cache) + ;; (remhash cname auth-source-cache) + ;; nil))) + (found nil)) + (if found + (progn + (auth-source-do-debug + "auth-source-user-or-password: DEPRECATED cached %s=%s for %s (%s) + %s" + mode + ;; don't show the password + (if (and (member "password" mode) t) + "SECRET" + found) + host port username) + found) ; return the found data + ;; else, if not found, search with a max of 1 + (let ((choice (nth 0 (apply #'auth-source-search + (append '(:max 1) search))))) + (when choice + (dolist (m mode) + (cond + ((equal "password" m) + (push (if (plist-get choice :secret) + (funcall (plist-get choice :secret)) + nil) found)) + ((equal "login" m) + (push (plist-get choice :user) found))))) + (setq found (nreverse found)) + (setq found (if listy found (car-safe found))))) + + found)) + +(defun auth-source-user-and-password (host &optional user) + (let* ((auth-info (car + (if user + (auth-source-search + :host host + :user "yourusername" + :max 1 + :require '(:user :secret) + :create nil) + (auth-source-search + :host host + :max 1 + :require '(:user :secret) + :create nil)))) + (user (plist-get auth-info :user)) + (password (plist-get auth-info :secret))) + (when (functionp password) + (setq password (funcall password))) + (list user password auth-info))) + +(provide 'auth-source) + +;;; auth-source.el ends here diff --cc lisp/calendar/icalendar.el index 2f557f547af,4c18292945a..aa092b233ef --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@@ -1,6 -1,6 +1,6 @@@ -;;; icalendar.el --- iCalendar implementation +;;; icalendar.el --- iCalendar implementation -*- lexical-binding: t -*- - ;; Copyright (C) 2002-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2002-2017 Free Software Foundation, Inc. ;; Author: Ulf Jasper ;; Created: August 2002 diff --cc lisp/dom.el index 9f5e177e986,bfdb2eb1a9a..4d0d4233db3 --- a/lisp/dom.el +++ b/lisp/dom.el @@@ -1,6 -1,6 +1,6 @@@ -;;; dom.el --- XML/HTML (etc.) DOM manipulation and searching functions +;;; dom.el --- XML/HTML (etc.) DOM manipulation and searching functions -*- lexical-binding: t -*- - ;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2014-2017 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: xml, html diff --cc lisp/ecomplete.el index b9f4b1ab846,00000000000..70277facb0a mode 100644,000000..100644 --- a/lisp/ecomplete.el +++ b/lisp/ecomplete.el @@@ -1,158 -1,0 +1,158 @@@ +;;; ecomplete.el --- electric completion of addresses and the like + - ;; Copyright (C) 2006-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2006-2017 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(eval-when-compile + (require 'cl)) + +(defgroup ecomplete nil + "Electric completion of email addresses and the like." + :group 'mail) + +(defcustom ecomplete-database-file "~/.ecompleterc" + "The name of the file to store the ecomplete data." + :group 'ecomplete + :type 'file) + +(defcustom ecomplete-database-file-coding-system 'iso-2022-7bit + "Coding system used for writing the ecomplete database file." + :type '(symbol :tag "Coding system") + :group 'ecomplete) + +;;; Internal variables. + +(defvar ecomplete-database nil) + +;;;###autoload +(defun ecomplete-setup () + (when (file-exists-p ecomplete-database-file) + (with-temp-buffer + (let ((coding-system-for-read ecomplete-database-file-coding-system)) + (insert-file-contents ecomplete-database-file) + (setq ecomplete-database (read (current-buffer))))))) + +(defun ecomplete-add-item (type key text) + (let ((elems (assq type ecomplete-database)) + (now (string-to-number (format "%.0f" (float-time)))) + entry) + (unless elems + (push (setq elems (list type)) ecomplete-database)) + (if (setq entry (assoc key (cdr elems))) + (setcdr entry (list (1+ (cadr entry)) now text)) + (nconc elems (list (list key 1 now text)))))) + +(defun ecomplete-get-item (type key) + (assoc key (cdr (assq type ecomplete-database)))) + +(defun ecomplete-save () + (with-temp-buffer + (let ((coding-system-for-write ecomplete-database-file-coding-system)) + (insert "(") + (loop for (type . elems) in ecomplete-database + do + (insert (format "(%s\n" type)) + (dolist (entry elems) + (prin1 entry (current-buffer)) + (insert "\n")) + (insert ")\n")) + (insert ")") + (write-region (point-min) (point-max) + ecomplete-database-file nil 'silent)))) + +(defun ecomplete-get-matches (type match) + (let* ((elems (cdr (assq type ecomplete-database))) + (match (regexp-quote match)) + (candidates + (sort + (loop for (key count time text) in elems + when (string-match match text) + collect (list count time text)) + (lambda (l1 l2) + (> (car l1) (car l2)))))) + (when (> (length candidates) 10) + (setcdr (nthcdr 10 candidates) nil)) + (unless (zerop (length candidates)) + (with-temp-buffer + (dolist (candidate candidates) + (insert (caddr candidate) "\n")) + (goto-char (point-min)) + (put-text-property (point) (1+ (point)) 'ecomplete t) + (while (re-search-forward match nil t) + (put-text-property (match-beginning 0) (match-end 0) + 'face 'isearch)) + (buffer-string))))) + +(defun ecomplete-display-matches (type word &optional choose) + (let* ((matches (ecomplete-get-matches type word)) + (line 0) + (max-lines (when matches (- (length (split-string matches "\n")) 2))) + (message-log-max nil) + command highlight) + (if (not matches) + (progn + (message "No ecomplete matches") + nil) + (if (not choose) + (progn + (message "%s" matches) + nil) + (setq highlight (ecomplete-highlight-match-line matches line)) + (let ((local-map (make-sparse-keymap)) + selected) + (define-key local-map (kbd "RET") + (lambda () (setq selected (nth line (split-string matches "\n"))))) + (define-key local-map (kbd "M-n") + (lambda () (setq line (min (1+ line) max-lines)))) + (define-key local-map (kbd "M-p") + (lambda () (setq line (max (1- line) 0)))) + (let ((overriding-local-map local-map)) + (while (and (null selected) + (setq command (read-key-sequence highlight)) + (lookup-key local-map command)) + (apply (key-binding command) nil) + (setq highlight (ecomplete-highlight-match-line matches line)))) + (if selected + (message selected) + (message "Abort")) + selected))))) + +(defun ecomplete-highlight-match-line (matches line) + (with-temp-buffer + (insert matches) + (goto-char (point-min)) + (forward-line line) + (save-restriction + (narrow-to-region (point) (point-at-eol)) + (while (not (eobp)) + ;; Put the 'region face on any characters on this line that + ;; aren't already highlighted. + (unless (get-text-property (point) 'face) + (put-text-property (point) (1+ (point)) 'face 'highlight)) + (forward-char 1))) + (buffer-string))) + +(provide 'ecomplete) + +;;; ecomplete.el ends here diff --cc lisp/emacs-lisp/let-alist.el index d7069174c1b,17bf7fb37fc..a45fc0a05c3 --- a/lisp/emacs-lisp/let-alist.el +++ b/lisp/emacs-lisp/let-alist.el @@@ -1,9 -1,9 +1,9 @@@ ;;; let-alist.el --- Easily let-bind values of an assoc-list by their names -*- lexical-binding: t; -*- - ;; Copyright (C) 2014-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2014-2017 Free Software Foundation, Inc. -;; Author: Artur Malabarba -;; Maintainer: Artur Malabarba +;; Author: Artur Malabarba +;; Package-Requires: ((emacs "24.1")) ;; Version: 1.0.4 ;; Keywords: extensions lisp ;; Prefix: let-alist diff --cc lisp/emacs-lisp/regexp-opt.el index 40033180770,8b91668c8c2..5feaad88c7b --- a/lisp/emacs-lisp/regexp-opt.el +++ b/lisp/emacs-lisp/regexp-opt.el @@@ -1,6 -1,6 +1,6 @@@ -;;; regexp-opt.el --- generate efficient regexps to match strings +;;; regexp-opt.el --- generate efficient regexps to match strings -*- lexical-binding: t -*- - ;; Copyright (C) 1994-2016 Free Software Foundation, Inc. + ;; Copyright (C) 1994-2017 Free Software Foundation, Inc. ;; Author: Simon Marshall ;; Maintainer: emacs-devel@gnu.org diff --cc lisp/emacs-lisp/ring.el index c6684ec9493,371723fa0b5..b0ec3bcbe01 --- a/lisp/emacs-lisp/ring.el +++ b/lisp/emacs-lisp/ring.el @@@ -1,6 -1,6 +1,6 @@@ -;;; ring.el --- handle rings of items +;;; ring.el --- handle rings of items -*- lexical-binding: t; -*- - ;; Copyright (C) 1992, 2001-2016 Free Software Foundation, Inc. + ;; Copyright (C) 1992, 2001-2017 Free Software Foundation, Inc. ;; Maintainer: emacs-devel@gnu.org ;; Keywords: extensions diff --cc lisp/emacs-lisp/timer.el index 64aebeaa818,ba87543f5b0..d872256dad4 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@@ -1,6 -1,6 +1,6 @@@ -;;; timer.el --- run a function with args at some time in future +;;; timer.el --- run a function with args at some time in future -*- lexical-binding: t -*- - ;; Copyright (C) 1996, 2001-2016 Free Software Foundation, Inc. + ;; Copyright (C) 1996, 2001-2017 Free Software Foundation, Inc. ;; Maintainer: emacs-devel@gnu.org ;; Package: emacs diff --cc lisp/emulation/viper-cmd.el index 3ce1b4d6a75,a65931deb58..86364282dcf --- a/lisp/emulation/viper-cmd.el +++ b/lisp/emulation/viper-cmd.el @@@ -1,6 -1,6 +1,6 @@@ -;;; viper-cmd.el --- Vi command support for Viper +;;; viper-cmd.el --- Vi command support for Viper -*- lexical-binding:t -*- - ;; Copyright (C) 1997-2016 Free Software Foundation, Inc. + ;; Copyright (C) 1997-2017 Free Software Foundation, Inc. ;; Author: Michael Kifer ;; Package: viper diff --cc lisp/erc/erc-backend.el index 288e8efe73e,3c3c966108c..8eac2e18aee --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@@ -1,6 -1,6 +1,6 @@@ -;;; erc-backend.el --- Backend network communication for ERC +;;; erc-backend.el --- Backend network communication for ERC -*- lexical-binding:t -*- - ;; Copyright (C) 2004-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2004-2017 Free Software Foundation, Inc. ;; Filename: erc-backend.el ;; Author: Lawrence Mitchell diff --cc lisp/faces.el index f536015e981,2d1c4ce4723..d4f2f08acf5 --- a/lisp/faces.el +++ b/lisp/faces.el @@@ -1,6 -1,6 +1,6 @@@ -;;; faces.el --- Lisp faces +;;; faces.el --- Lisp faces -*- lexical-binding: t -*- - ;; Copyright (C) 1992-1996, 1998-2016 Free Software Foundation, Inc. + ;; Copyright (C) 1992-1996, 1998-2017 Free Software Foundation, Inc. ;; Maintainer: emacs-devel@gnu.org ;; Keywords: internal diff --cc lisp/gnus/message.el index 33c5339e54c,55ce56bcf2c..4d4ba089434 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@@ -1,6 -1,6 +1,6 @@@ -;;; message.el --- composing mail and news messages +;;; message.el --- composing mail and news messages -*- lexical-binding: t -*- - ;; Copyright (C) 1996-2016 Free Software Foundation, Inc. + ;; Copyright (C) 1996-2017 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: mail, news diff --cc lisp/hex-util.el index 889bf9bfed5,943f1eb03b2..e2e3d7f07c0 --- a/lisp/hex-util.el +++ b/lisp/hex-util.el @@@ -1,6 -1,6 +1,6 @@@ -;;; hex-util.el --- Functions to encode/decode hexadecimal string. +;;; hex-util.el --- Functions to encode/decode hexadecimal string -*- lexical-binding: t -*- - ;; Copyright (C) 1999, 2001-2016 Free Software Foundation, Inc. + ;; Copyright (C) 1999, 2001-2017 Free Software Foundation, Inc. ;; Author: Shuhei KOBAYASHI ;; Keywords: data diff --cc lisp/htmlfontify.el index 19a57ba8b2e,5c85da30ddf..21aac1ab216 --- a/lisp/htmlfontify.el +++ b/lisp/htmlfontify.el @@@ -1,6 -1,6 +1,6 @@@ -;;; htmlfontify.el --- htmlize a buffer/source tree with optional hyperlinks +;;; htmlfontify.el --- htmlize a buffer/source tree with optional hyperlinks -*- lexical-binding: t -*- - ;; Copyright (C) 2002-2003, 2009-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2002-2003, 2009-2017 Free Software Foundation, Inc. ;; Emacs Lisp Archive Entry ;; Package: htmlfontify diff --cc lisp/image-dired.el index 2af72fc4527,0d49e0d70f3..901225fa2e9 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@@ -1,6 -1,6 +1,6 @@@ -;;; image-dired.el --- use dired to browse and manipulate your images +;;; image-dired.el --- use dired to browse and manipulate your images -*- lexical-binding: t -*- ;; - ;; Copyright (C) 2005-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2005-2017 Free Software Foundation, Inc. ;; ;; Version: 0.4.11 ;; Keywords: multimedia diff --cc lisp/image.el index c34db68a44a,00062bba236..8cea7fb2c8b --- a/lisp/image.el +++ b/lisp/image.el @@@ -1,6 -1,6 +1,6 @@@ -;;; image.el --- image API +;;; image.el --- image API -*- lexical-binding:t -*- - ;; Copyright (C) 1998-2016 Free Software Foundation, Inc. + ;; Copyright (C) 1998-2017 Free Software Foundation, Inc. ;; Maintainer: emacs-devel@gnu.org ;; Keywords: multimedia diff --cc lisp/image/compface.el index e2f607b1be3,00000000000..f4c3d5f4df0 mode 100644,000000..100644 --- a/lisp/image/compface.el +++ b/lisp/image/compface.el @@@ -1,55 -1,0 +1,55 @@@ +;;; compface.el --- functions for converting X-Face headers + - ;; Copyright (C) 2002-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2002-2017 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +;;;### +(defun uncompface (face) + "Convert FACE to pbm. +Requires the external programs `uncompface', and `icontopbm'. On a +GNU/Linux system these might be in packages with names like `compface' +or `faces-xface' and `netpbm' or `libgr-progs', for instance." + (with-temp-buffer + (set-buffer-multibyte nil) + (insert face) + (let ((coding-system-for-read 'raw-text) + ;; At least "icontopbm" doesn't work with Windows because + ;; the line-break code is converted into CRLF by default. + (coding-system-for-write 'binary)) + (and (eq 0 (apply 'call-process-region (point-min) (point-max) + "uncompface" + 'delete '(t nil) nil)) + (progn + (goto-char (point-min)) + (insert "/* Format_version=1, Width=48, Height=48, Depth=1,\ + Valid_bits_per_item=16 */\n") + ;; Emacs doesn't understand un-raw pbm files. + (eq 0 (call-process-region (point-min) (point-max) + "icontopbm" + 'delete '(t nil)))) + (buffer-string))))) + +(provide 'compface) + +;;; compface.el ends here diff --cc lisp/image/gravatar.el index 4bf5875f08c,00000000000..54ca3be96ae mode 100644,000000..100644 --- a/lisp/image/gravatar.el +++ b/lisp/image/gravatar.el @@@ -1,157 -1,0 +1,157 @@@ +;;; gravatar.el --- Get Gravatars + - ;; Copyright (C) 2010-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2010-2017 Free Software Foundation, Inc. + +;; Author: Julien Danjou +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'url) +(require 'url-cache) +(require 'image) + +(defgroup gravatar nil + "Gravatar." + :version "24.1" + :group 'comm) + +(defcustom gravatar-automatic-caching t + "Whether to cache retrieved gravatars." + :type 'boolean + :group 'gravatar) + +;; FIXME a time value is not the nicest format for a custom variable. +(defcustom gravatar-cache-ttl (days-to-time 30) + "Time to live for gravatar cache entries." + :type '(repeat integer) + :group 'gravatar) + +;; FIXME Doc is tautological. What are the options? +(defcustom gravatar-rating "g" + "Default rating for gravatar." + :type 'string + :group 'gravatar) + +(defcustom gravatar-size 32 + "Default size in pixels for gravatars." + :type 'integer + :group 'gravatar) + +(defconst gravatar-base-url + "http://www.gravatar.com/avatar" + "Base URL for getting gravatars.") + +(defun gravatar-hash (mail-address) + "Create an hash from MAIL-ADDRESS." + (md5 (downcase mail-address))) + +(defun gravatar-build-url (mail-address) + "Return an URL to retrieve MAIL-ADDRESS gravatar." + (format "%s/%s?d=404&r=%s&s=%d" + gravatar-base-url + (gravatar-hash mail-address) + gravatar-rating + gravatar-size)) + +(defun gravatar-cache-expired (url) + "Check if URL is cached for more than `gravatar-cache-ttl'." + (cond (url-standalone-mode + (not (file-exists-p (url-cache-create-filename url)))) + (t (let ((cache-time (url-is-cached url))) + (if cache-time + (time-less-p + (time-add + cache-time + gravatar-cache-ttl) + (current-time)) + t))))) + +(defun gravatar-get-data () + "Get data from current buffer." + (save-excursion + (goto-char (point-min)) + (when (re-search-forward "^HTTP/.+ 200 OK$" nil (line-end-position)) + (when (search-forward "\n\n" nil t) + (buffer-substring (point) (point-max)))))) + +(defun gravatar-data->image () + "Get data of current buffer and return an image. +If no image available, return 'error." + (let ((data (gravatar-get-data))) + (if data + (create-image data nil t) + 'error))) + +(autoload 'help-function-arglist "help-fns") + +;;;###autoload +(defun gravatar-retrieve (mail-address cb &optional cbargs) + "Retrieve MAIL-ADDRESS gravatar and call CB on retrieval. +You can provide a list of argument to pass to CB in CBARGS." + (let ((url (gravatar-build-url mail-address))) + (if (gravatar-cache-expired url) + (let ((args (list url + 'gravatar-retrieved + (list cb (when cbargs cbargs))))) + (when (> (length (if (featurep 'xemacs) + (cdr (split-string (function-arglist 'url-retrieve))) + (help-function-arglist 'url-retrieve))) + 4) + (setq args (nconc args (list t)))) + (apply #'url-retrieve args)) + (apply cb + (with-temp-buffer + (set-buffer-multibyte nil) + (url-cache-extract (url-cache-create-filename url)) + (gravatar-data->image)) + cbargs)))) + +;;;###autoload +(defun gravatar-retrieve-synchronously (mail-address) + "Retrieve MAIL-ADDRESS gravatar and returns it." + (let ((url (gravatar-build-url mail-address))) + (if (gravatar-cache-expired url) + (with-current-buffer (url-retrieve-synchronously url) + (when gravatar-automatic-caching + (url-store-in-cache (current-buffer))) + (let ((data (gravatar-data->image))) + (kill-buffer (current-buffer)) + data)) + (with-temp-buffer + (set-buffer-multibyte nil) + (url-cache-extract (url-cache-create-filename url)) + (gravatar-data->image))))) + + +(defun gravatar-retrieved (status cb &optional cbargs) + "Callback function used by `gravatar-retrieve'." + ;; Store gravatar? + (when gravatar-automatic-caching + (url-store-in-cache (current-buffer))) + (if (plist-get status :error) + ;; Error happened. + (apply cb 'error cbargs) + (apply cb (gravatar-data->image) cbargs)) + (kill-buffer (current-buffer))) + +(provide 'gravatar) + +;;; gravatar.el ends here diff --cc lisp/info-xref.el index 81a2a5a0167,c797a772820..8c029d46b30 --- a/lisp/info-xref.el +++ b/lisp/info-xref.el @@@ -1,6 -1,6 +1,6 @@@ -;;; info-xref.el --- check external references in an Info document +;;; info-xref.el --- check external references in an Info document -*- lexical-binding: t -*- - ;; Copyright (C) 2003-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2003-2017 Free Software Foundation, Inc. ;; Author: Kevin Ryde ;; Keywords: docs diff --cc lisp/international/rfc1843.el index 508629fb062,00000000000..c1343274c93 mode 100644,000000..100644 --- a/lisp/international/rfc1843.el +++ b/lisp/international/rfc1843.el @@@ -1,131 -1,0 +1,131 @@@ +;;; rfc1843.el --- HZ (rfc1843) decoding + - ;; Copyright (C) 1998-2016 Free Software Foundation, Inc. ++;; Copyright (C) 1998-2017 Free Software Foundation, Inc. + +;; Author: Shenghuo Zhu +;; Keywords: news HZ HZ+ mail i18n + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Test: +;; (rfc1843-decode-string "~{<:Ky2;S{#,NpJ)l6HK!#~}") + +;;; Code: + +(eval-when-compile (require 'cl)) + +(defvar rfc1843-word-regexp + "~\\({\\([\041-\167][\041-\176]\\| \\)+\\)\\(~}\\|$\\)") + +(defvar rfc1843-word-regexp-strictly + "~\\({\\([\041-\167][\041-\176]\\)+\\)\\(~}\\|$\\)") + +(defvar rfc1843-hzp-word-regexp + "~\\({\\([\041-\167][\041-\176]\\| \\)+\\|\ +[<>]\\([\041-\175][\041-\176]\\| \\)+\\)\\(~}\\|$\\)") + +(defvar rfc1843-hzp-word-regexp-strictly + "~\\({\\([\041-\167][\041-\176]\\)+\\|\ +[<>]\\([\041-\175][\041-\176]\\)+\\)\\(~}\\|$\\)") + +(defcustom rfc1843-decode-loosely nil + "Loosely check HZ encoding if non-nil. +When it is set non-nil, only buffers or strings with strictly +HZ-encoded are decoded." + :type 'boolean + :group 'mime) + +(defcustom rfc1843-decode-hzp t + "HZ+ decoding support if non-nil. +HZ+ specification (also known as HZP) is to provide a standardized +7-bit representation of mixed Big5, GB, and ASCII text for convenient +e-mail transmission, news posting, etc. +The document of HZ+ 0.78 specification can be found at +ftp://ftp.math.psu.edu/pub/simpson/chinese/hzp/hzp.doc" + :type 'boolean + :group 'mime) + +(defcustom rfc1843-newsgroups-regexp "chinese\\|hz" + "Regexp of newsgroups in which might be HZ encoded." + :type 'string + :group 'mime) + +(defun rfc1843-decode-region (from to) + "Decode HZ in the region between FROM and TO." + (interactive "r") + (let (str firstc) + (save-excursion + (goto-char from) + (if (or rfc1843-decode-loosely + (re-search-forward (if rfc1843-decode-hzp + rfc1843-hzp-word-regexp-strictly + rfc1843-word-regexp-strictly) to t)) + (save-restriction + (narrow-to-region from to) + (goto-char (point-min)) + (while (re-search-forward (if rfc1843-decode-hzp + rfc1843-hzp-word-regexp + rfc1843-word-regexp) (point-max) t) + (setq str (buffer-substring-no-properties + (match-beginning 1) + (match-end 1))) + (setq firstc (aref str 0)) + (insert (decode-coding-string + (rfc1843-decode + (prog1 + (substring str 1) + (delete-region (match-beginning 0) (match-end 0))) + firstc) + (if (eq firstc ?{) 'cn-gb-2312 'cn-big5)))) + (goto-char (point-min)) + (while (search-forward "~" (point-max) t) + (cond ((eq (char-after) ?\n) + (delete-char -1) + (delete-char 1)) + ((eq (char-after) ?~) + (delete-char 1))))))))) + +(defun rfc1843-decode-string (string) + "Decode HZ STRING and return the results." + (let ((m enable-multibyte-characters)) + (with-temp-buffer + (when m + (set-buffer-multibyte 'to)) + (insert string) + (inline + (rfc1843-decode-region (point-min) (point-max))) + (buffer-string)))) + +(defun rfc1843-decode (word &optional firstc) + "Decode HZ WORD and return it." + (let ((i -1) (s (substring word 0)) v) + (if (or (not firstc) (eq firstc ?{)) + (while (< (incf i) (length s)) + (if (eq (setq v (aref s i)) ? ) nil + (aset s i (+ 128 v)))) + (while (< (incf i) (length s)) + (if (eq (setq v (aref s i)) ? ) nil + (setq v (+ (* 94 v) (aref s (1+ i)) -3135)) + (aset s i (+ (/ v 157) (if (eq firstc ?<) 201 161))) + (setq v (% v 157)) + (aset s (incf i) (+ v (if (< v 63) 64 98)))))) + s)) + +(provide 'rfc1843) + +;;; rfc1843.el ends here diff --cc lisp/international/utf7.el index bd04eba2fae,00000000000..82dad3da6eb mode 100644,000000..100644 --- a/lisp/international/utf7.el +++ b/lisp/international/utf7.el @@@ -1,236 -1,0 +1,236 @@@ +;;; utf7.el --- UTF-7 encoding/decoding for Emacs -*-coding: utf-8;-*- + - ;; Copyright (C) 1999-2016 Free Software Foundation, Inc. ++;; Copyright (C) 1999-2017 Free Software Foundation, Inc. + +;; Author: Jon K Hellan +;; Maintainer: bugs@gnus.org +;; Keywords: mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; UTF-7 - A Mail-Safe Transformation Format of Unicode - RFC 2152 +;; This is a transformation format of Unicode that contains only 7-bit +;; ASCII octets and is intended to be readable by humans in the limiting +;; case that the document consists of characters from the US-ASCII +;; repertoire. +;; In short, runs of characters outside US-ASCII are encoded as base64 +;; inside delimiters. +;; A variation of UTF-7 is specified in IMAP 4rev1 (RFC 2060) as the way +;; to represent characters outside US-ASCII in mailbox names in IMAP. +;; This library supports both variants, but the IMAP variation was the +;; reason I wrote it. +;; The routines convert UTF-7 -> UTF-16 (16 bit encoding of Unicode) +;; -> current character set, and vice versa. +;; However, until Emacs supports Unicode, the only Emacs character set +;; supported here is ISO-8859.1, which can trivially be converted to/from +;; Unicode. +;; When decoding results in a character outside the Emacs character set, +;; an error is thrown. It is up to the application to recover. + +;; UTF-7 should be done by providing a coding system. Mule-UCS does +;; already, but I don't know if it does the IMAP version and it's not +;; clear whether that should really be a coding system. The UTF-16 +;; part of the conversion can be done with coding systems available +;; with Mule-UCS or some versions of Emacs. Unfortunately these were +;; done wrongly (regarding handling of byte-order marks and how the +;; variants were named), so we don't have a consistent name for the +;; necessary coding system. The code below doesn't seem to DTRT +;; generally. E.g.: +;; +;; (utf7-encode "a+£") +;; => "a+ACsAow-" +;; +;; $ echo "a+£"|iconv -f utf-8 -t utf-7 +;; a+-+AKM +;; +;; -- fx + + +;;; Code: + +(require 'base64) +(eval-when-compile (require 'cl)) +(require 'mm-util) + +(defconst utf7-direct-encoding-chars " -%'-*,-[]-}" + "Character ranges which do not need escaping in UTF-7.") + +(defconst utf7-imap-direct-encoding-chars + (concat utf7-direct-encoding-chars "+\\~") + "Character ranges which do not need escaping in the IMAP variant of UTF-7.") + +(defconst utf7-utf-16-coding-system + (cond ((mm-coding-system-p 'utf-16-be-no-signature) ; Mule-UCS + 'utf-16-be-no-signature) + ((and (mm-coding-system-p 'utf-16-be) ; Emacs + ;; Avoid versions with BOM. + (= 2 (length (encode-coding-string "a" 'utf-16-be)))) + 'utf-16-be) + ((mm-coding-system-p 'utf-16-be-nosig) ; ? + 'utf-16-be-nosig)) + "Coding system which encodes big endian UTF-16 without a BOM signature.") + +(defsubst utf7-imap-get-pad-length (len modulus) + "Return required length of padding for IMAP modified base64 fragment." + (mod (- len) modulus)) + +(defun utf7-encode-internal (&optional for-imap) + "Encode text in (temporary) buffer as UTF-7. +Use IMAP modification if FOR-IMAP is non-nil." + (let ((start (point-min)) + (end (point-max))) + (narrow-to-region start end) + (goto-char start) + (let* ((esc-char (if for-imap ?& ?+)) + (direct-encoding-chars + (if for-imap utf7-imap-direct-encoding-chars + utf7-direct-encoding-chars)) + (not-direct-encoding-chars (concat "^" direct-encoding-chars))) + (while (not (eobp)) + (skip-chars-forward direct-encoding-chars) + (unless (eobp) + (insert esc-char) + (let ((p (point)) + (fc (following-char)) + (run-length + (skip-chars-forward not-direct-encoding-chars))) + (if (and (= fc esc-char) + (= run-length 1)) ; Lone esc-char? + (delete-char -1) ; Now there's one too many + (utf7-fragment-encode p (point) for-imap)) + (insert "-"))))))) + +(defun utf7-fragment-encode (start end &optional for-imap) + "Encode text from START to END in buffer as UTF-7 escape fragment. +Use IMAP modification if FOR-IMAP is non-nil." + (save-restriction + (let* ((buf (current-buffer)) + (base (with-temp-buffer + (set-buffer-multibyte nil) + (insert-buffer-substring buf start end) + (funcall (utf7-get-u16char-converter 'to-utf-16)) + (base64-encode-region (point-min) (point-max)) + (buffer-string)))) + (narrow-to-region start end) + (delete-region (point-min) (point-max)) + (insert base)) + (goto-char (point-min)) + (let ((pm (point-max))) + (when for-imap + (while (search-forward "/" nil t) + (replace-match ","))) + (skip-chars-forward "^= \t\n" pm) + (delete-region (point) pm)))) + +(defun utf7-decode-internal (&optional for-imap) + "Decode UTF-7 text in (temporary) buffer. +Use IMAP modification if FOR-IMAP is non-nil." + (let ((start (point-min)) + (end (point-max))) + (goto-char start) + (let* ((esc-pattern (concat "^" (char-to-string (if for-imap ?& ?+)))) + (base64-chars (concat "A-Za-z0-9+" + (char-to-string (if for-imap ?, ?/))))) + (while (not (eobp)) + (skip-chars-forward esc-pattern) + (unless (eobp) + (forward-char) + (let ((p (point)) + (run-length (skip-chars-forward base64-chars))) + (when (and (not (eobp)) (= (following-char) ?-)) + (delete-char 1)) + (unless (= run-length 0) ; Encoded lone esc-char? + (save-excursion + (utf7-fragment-decode p (point) for-imap) + (goto-char p) + (delete-char -1))))))))) + +(defun utf7-fragment-decode (start end &optional for-imap) + "Decode base64 encoded fragment from START to END of UTF-7 text in buffer. +Use IMAP modification if FOR-IMAP is non-nil." + (save-restriction + (narrow-to-region start end) + (when for-imap + (goto-char start) + (while (search-forward "," nil 'move-to-end) (replace-match "/"))) + (let ((pl (utf7-imap-get-pad-length (- end start) 4))) + (insert (make-string pl ?=)) + (base64-decode-region start (+ end pl))) + (funcall (utf7-get-u16char-converter 'from-utf-16)))) + +(defun utf7-get-u16char-converter (which-way) + "Return a function to convert between UTF-16 and current character set." + (if utf7-utf-16-coding-system + (if (eq which-way 'to-utf-16) + (lambda () + (encode-coding-region (point-min) (point-max) + utf7-utf-16-coding-system)) + (lambda () + (decode-coding-region (point-min) (point-max) + utf7-utf-16-coding-system))) + ;; Add test to check if we are really Latin-1. + (if (eq which-way 'to-utf-16) + 'utf7-latin1-u16-char-converter + 'utf7-u16-latin1-char-converter))) + +(defun utf7-latin1-u16-char-converter () + "Convert latin 1 (ISO-8859.1) characters to 16 bit Unicode. +Characters are converted to raw byte pairs in narrowed buffer." + (encode-coding-region (point-min) (point-max) 'iso-8859-1) + (goto-char (point-min)) + (while (not (eobp)) + (insert 0) + (forward-char))) + +(defun utf7-u16-latin1-char-converter () + "Convert 16 bit Unicode characters to latin 1 (ISO-8859.1). +Characters are in raw byte pairs in narrowed buffer." + (goto-char (point-min)) + (while (not (eobp)) + (if (= 0 (following-char)) + (delete-char 1) + (error "Unable to convert from Unicode")) + (forward-char)) + (decode-coding-region (point-min) (point-max) 'iso-8859-1) + (mm-enable-multibyte)) + +;;;###autoload +(defun utf7-encode (string &optional for-imap) + "Encode UTF-7 STRING. Use IMAP modification if FOR-IMAP is non-nil." + (if (and (coding-system-p 'utf-7) (coding-system-p 'utf-7-imap)) + ;; Emacs 23 with proper support for IMAP + (encode-coding-string string (if for-imap 'utf-7-imap 'utf-7)) + (mm-with-multibyte-buffer + (insert string) + (utf7-encode-internal for-imap) + (buffer-string)))) + +(defun utf7-decode (string &optional for-imap) + "Decode UTF-7 STRING. Use IMAP modification if FOR-IMAP is non-nil." + (if (and (coding-system-p 'utf-7) (coding-system-p 'utf-7-imap)) + ;; Emacs 23 with proper support for IMAP + (decode-coding-string string (if for-imap 'utf-7-imap 'utf-7)) + (mm-with-unibyte-buffer + (insert string) + (utf7-decode-internal for-imap) + (mm-enable-multibyte) + (buffer-string)))) + +(provide 'utf7) + +;;; utf7.el ends here diff --cc lisp/isearch.el index 9846f0b7206,d09f81be080..b890cc49c0d --- a/lisp/isearch.el +++ b/lisp/isearch.el @@@ -1,6 -1,6 +1,6 @@@ -;;; isearch.el --- incremental search minor mode +;;; isearch.el --- incremental search minor mode -*- lexical-binding: t -*- - ;; Copyright (C) 1992-1997, 1999-2016 Free Software Foundation, Inc. + ;; Copyright (C) 1992-1997, 1999-2017 Free Software Foundation, Inc. ;; Author: Daniel LaLiberte ;; Maintainer: emacs-devel@gnu.org diff --cc lisp/json.el index fdac8d9a826,0cef554c56e..38f828e8fbb --- a/lisp/json.el +++ b/lisp/json.el @@@ -1,6 -1,6 +1,6 @@@ -;;; json.el --- JavaScript Object Notation parser / generator +;;; json.el --- JavaScript Object Notation parser / generator -*- lexical-binding: t -*- - ;; Copyright (C) 2006-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2006-2017 Free Software Foundation, Inc. ;; Author: Edward O'Connor ;; Version: 1.4 diff --cc lisp/mail/flow-fill.el index d2881422475,00000000000..860d353002c mode 100644,000000..100644 --- a/lisp/mail/flow-fill.el +++ b/lisp/mail/flow-fill.el @@@ -1,240 -1,0 +1,240 @@@ +;;; flow-fill.el --- interpret RFC2646 "flowed" text + - ;; Copyright (C) 2000-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2000-2017 Free Software Foundation, Inc. + +;; Author: Simon Josefsson +;; Keywords: mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This implement decoding of RFC2646 formatted text, including the +;; quoted-depth wins rules. + +;; Theory of operation: search for lines ending with SPC, save quote +;; length of line, remove SPC and concatenate line with the following +;; line if quote length of following line matches current line. + +;; When no further concatenations are possible, we've found a +;; paragraph and we let `fill-region' fill the long line into several +;; lines with the quote prefix as `fill-prefix'. + +;; Todo: implement basic `fill-region' (Emacs and XEmacs +;; implementations differ..) + +;;; History: + +;; 2000-02-17 posted on ding mailing list +;; 2000-02-19 use `point-at-{b,e}ol' in XEmacs +;; 2000-03-11 no compile warnings for point-at-bol stuff +;; 2000-03-26 committed to gnus cvs +;; 2000-10-23 don't flow "-- " lines, make "quote-depth wins" rule +;; work when first line is at level 0. +;; 2002-01-12 probably incomplete encoding support +;; 2003-12-08 started working on test harness. + +;;; Code: + +(eval-when-compile (require 'cl)) + +(defcustom fill-flowed-display-column 'fill-column + "Column beyond which format=flowed lines are wrapped, when displayed. +This can be a Lisp expression or an integer." + :version "22.1" + :group 'mime-display + :type '(choice (const :tag "Standard `fill-column'" fill-column) + (const :tag "Fit Window" (- (window-width) 5)) + (sexp) + (integer))) + +(defcustom fill-flowed-encode-column 66 + "Column beyond which format=flowed lines are wrapped, in outgoing messages. +This can be a Lisp expression or an integer. +RFC 2646 suggests 66 characters for readability." + :version "22.1" + :group 'mime-display + :type '(choice (const :tag "Standard fill-column" fill-column) + (const :tag "RFC 2646 default (66)" 66) + (sexp) + (integer))) + +;;;###autoload +(defun fill-flowed-encode (&optional buffer) + (with-current-buffer (or buffer (current-buffer)) + ;; No point in doing this unless hard newlines is used. + (when use-hard-newlines + (let ((start (point-min)) end) + ;; Go through each paragraph, filling it and adding SPC + ;; as the last character on each line. + (while (setq end (text-property-any start (point-max) 'hard 't)) + (save-restriction + (narrow-to-region start end) + (let ((fill-column (eval fill-flowed-encode-column))) + (fill-flowed-fill-buffer)) + (goto-char (point-min)) + (while (re-search-forward "\n" nil t) + (replace-match " \n" t t)) + (goto-char (setq start (1+ (point-max))))))) + t))) + +(defun fill-flowed-fill-buffer () + (let ((prefix nil) + (prev-prefix nil) + (start (point-min))) + (goto-char (point-min)) + (while (not (eobp)) + (setq prefix (and (looking-at "[> ]+") + (match-string 0))) + (if (equal prefix prev-prefix) + (forward-line 1) + (save-restriction + (narrow-to-region start (point)) + (let ((fill-prefix prev-prefix)) + (fill-region (point-min) (point-max) t 'nosqueeze 'to-eop)) + (goto-char (point-max))) + (setq prev-prefix prefix + start (point)))) + (save-restriction + (narrow-to-region start (point)) + (let ((fill-prefix prev-prefix)) + (fill-region (point-min) (point-max) t 'nosqueeze 'to-eop))))) + +;;;###autoload +(defun fill-flowed (&optional buffer delete-space) + (with-current-buffer (or (current-buffer) buffer) + (goto-char (point-min)) + ;; Remove space stuffing. + (while (re-search-forward "^\\( \\|>+ $\\)" nil t) + (delete-char -1) + (forward-line 1)) + (goto-char (point-min)) + (while (re-search-forward " $" nil t) + (when (save-excursion + (beginning-of-line) + (looking-at "^\\(>*\\)\\( ?\\)")) + (let ((quote (match-string 1)) + sig) + (if (string= quote "") + (setq quote nil)) + (when (and quote (string= (match-string 2) "")) + (save-excursion + ;; insert SP after quote for pleasant reading of quoted lines + (beginning-of-line) + (when (> (skip-chars-forward ">") 0) + (insert " ")))) + ;; XXX slightly buggy handling of "-- " + (while (and (save-excursion + (ignore-errors (backward-char 3)) + (setq sig (looking-at "-- ")) + (looking-at "[^-][^-] ")) + (save-excursion + (unless (eobp) + (forward-char 1) + (looking-at (format "^\\(%s\\)\\([^>\n\r]\\)" + (or quote " ?")))))) + (save-excursion + (replace-match (if (string= (match-string 2) " ") + "" "\\2"))) + (backward-delete-char -1) + (when delete-space + (delete-char -1)) + (end-of-line)) + (unless sig + (condition-case nil + (let ((fill-prefix (when quote (concat quote " "))) + (fill-column (eval fill-flowed-display-column)) + adaptive-fill-mode) + (fill-region (point-at-bol) + (min (1+ (point-at-eol)) + (point-max)) + 'left 'nosqueeze)) + (error + (forward-line 1) + nil)))))))) + +;; Test vectors. + +(defvar show-trailing-whitespace) + +(defvar fill-flowed-encode-tests + `( + ;; The syntax of each list element is: + ;; (INPUT . EXPECTED-OUTPUT) + (,(concat + "> Thou villainous ill-breeding spongy dizzy-eyed \n" + "> reeky elf-skinned pigeon-egg! \n" + ">> Thou artless swag-bellied milk-livered \n" + ">> dismal-dreaming idle-headed scut!\n" + ">>> Thou errant folly-fallen spleeny reeling-ripe \n" + ">>> unmuzzled ratsbane!\n" + ">>>> Henceforth, the coding style is to be strictly \n" + ">>>> enforced, including the use of only upper case.\n" + ">>>>> I've noticed a lack of adherence to the coding \n" + ">>>>> styles, of late.\n" + ">>>>>> Any complaints?") + . + ,(concat + "> Thou villainous ill-breeding spongy dizzy-eyed reeky elf-skinned\n" + "> pigeon-egg! \n" + ">> Thou artless swag-bellied milk-livered dismal-dreaming idle-headed\n" + ">> scut!\n" + ">>> Thou errant folly-fallen spleeny reeling-ripe unmuzzled ratsbane!\n" + ">>>> Henceforth, the coding style is to be strictly enforced,\n" + ">>>> including the use of only upper case.\n" + ">>>>> I've noticed a lack of adherence to the coding styles, of late.\n" + ">>>>>> Any complaints?\n" + )) + ;; (,(concat + ;; "\n" + ;; "> foo\n" + ;; "> \n" + ;; "> \n" + ;; "> bar\n") + ;; . + ;; ,(concat + ;; "\n" + ;; "> foo bar\n")) + )) + +(defun fill-flowed-test () + (interactive "") + (switch-to-buffer (get-buffer-create "*Format=Flowed test output*")) + (erase-buffer) + (setq show-trailing-whitespace t) + (dolist (test fill-flowed-encode-tests) + (let (start output) + (insert "***** BEGIN TEST INPUT *****\n") + (insert (car test)) + (insert "***** END TEST INPUT *****\n\n") + (insert "***** BEGIN TEST OUTPUT *****\n") + (setq start (point)) + (insert (car test)) + (save-restriction + (narrow-to-region start (point)) + (fill-flowed)) + (setq output (buffer-substring start (point-max))) + (insert "***** END TEST OUTPUT *****\n") + (unless (string= output (cdr test)) + (insert "\n***** BEGIN TEST EXPECTED OUTPUT *****\n") + (insert (cdr test)) + (insert "***** END TEST EXPECTED OUTPUT *****\n")) + (insert "\n\n"))) + (goto-char (point-max))) + +(provide 'flow-fill) + +;;; flow-fill.el ends here diff --cc lisp/mail/ietf-drums.el index 03349d12055,00000000000..8c84158a51a mode 100644,000000..100644 --- a/lisp/mail/ietf-drums.el +++ b/lisp/mail/ietf-drums.el @@@ -1,291 -1,0 +1,291 @@@ +;;; ietf-drums.el --- Functions for parsing RFC822bis headers + - ;; Copyright (C) 1998-2016 Free Software Foundation, Inc. ++;; Copyright (C) 1998-2017 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; DRUMS is an IETF Working Group that works (or worked) on the +;; successor to RFC822, "Standard For The Format Of Arpa Internet Text +;; Messages". This library is based on +;; draft-ietf-drums-msg-fmt-05.txt, released on 1998-08-05. + +;; Pending a real regression self test suite, Simon Josefsson added +;; various self test expressions snipped from bug reports, and their +;; expected value, below. I you believe it could be useful, please +;; add your own test cases, or write a real self test suite, or just +;; remove this. + +;; +;; (ietf-drums-parse-address "'foo' ") +;; => ("foo@example.com" . "'foo'") + +;;; Code: + +(eval-when-compile (require 'cl)) + +(defvar ietf-drums-no-ws-ctl-token "\001-\010\013\014\016-\037\177" + "US-ASCII control characters excluding CR, LF and white space.") +(defvar ietf-drums-text-token "\001-\011\013\014\016-\177" + "US-ASCII characters excluding CR and LF.") +(defvar ietf-drums-specials-token "()<>[]:;@\\,.\"" + "Special characters.") +(defvar ietf-drums-quote-token "\\" + "Quote character.") +(defvar ietf-drums-wsp-token " \t" + "White space.") +(defvar ietf-drums-fws-regexp + (concat "[" ietf-drums-wsp-token "]*\n[" ietf-drums-wsp-token "]+") + "Folding white space.") +(defvar ietf-drums-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~" + "Textual token.") +(defvar ietf-drums-dot-atext-token "-^a-zA-Z0-9!#$%&'*+/=?_`{|}~." + "Textual token including full stop.") +(defvar ietf-drums-qtext-token + (concat ietf-drums-no-ws-ctl-token "\041\043-\133\135-\177") + "Non-white-space control characters, plus the rest of ASCII excluding +backslash and doublequote.") +(defvar ietf-drums-tspecials "][()<>@,;:\\\"/?=" + "Tspecials.") + +(defvar ietf-drums-syntax-table + (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) + (modify-syntax-entry ?\\ "/" table) + (modify-syntax-entry ?< "(" table) + (modify-syntax-entry ?> ")" table) + (modify-syntax-entry ?@ "w" table) + (modify-syntax-entry ?/ "w" table) + (modify-syntax-entry ?* "_" table) + (modify-syntax-entry ?\; "_" table) + (modify-syntax-entry ?\' "_" table) + table)) + +(defun ietf-drums-token-to-list (token) + "Translate TOKEN into a list of characters." + (let ((i 0) + b e c out range) + (while (< i (length token)) + (setq c (aref token i)) + (incf i) + (cond + ((eq c ?-) + (if b + (setq range t) + (push c out))) + (range + (while (<= b c) + (push (make-char 'ascii b) out) + (incf b)) + (setq range nil)) + ((= i (length token)) + (push (make-char 'ascii c) out)) + (t + (when b + (push (make-char 'ascii b) out)) + (setq b c)))) + (nreverse out))) + +(defsubst ietf-drums-init (string) + (set-syntax-table ietf-drums-syntax-table) + (insert string) + (ietf-drums-unfold-fws) + (goto-char (point-min))) + +(defun ietf-drums-remove-comments (string) + "Remove comments from STRING." + (with-temp-buffer + (let (c) + (ietf-drums-init string) + (while (not (eobp)) + (setq c (char-after)) + (cond + ((eq c ?\") + (condition-case err + (forward-sexp 1) + (error (goto-char (point-max))))) + ((eq c ?\() + (delete-region + (point) + (condition-case nil + (with-syntax-table (copy-syntax-table ietf-drums-syntax-table) + (modify-syntax-entry ?\" "w") + (forward-sexp 1) + (point)) + (error (point-max))))) + (t + (forward-char 1)))) + (buffer-string)))) + +(defun ietf-drums-remove-whitespace (string) + "Remove whitespace from STRING." + (with-temp-buffer + (ietf-drums-init string) + (let (c) + (while (not (eobp)) + (setq c (char-after)) + (cond + ((eq c ?\") + (forward-sexp 1)) + ((eq c ?\() + (forward-sexp 1)) + ((memq c '(?\ ?\t ?\n)) + (delete-char 1)) + (t + (forward-char 1)))) + (buffer-string)))) + +(defun ietf-drums-get-comment (string) + "Return the first comment in STRING." + (with-temp-buffer + (ietf-drums-init string) + (let (result c) + (while (not (eobp)) + (setq c (char-after)) + (cond + ((eq c ?\") + (forward-sexp 1)) + ((eq c ?\() + (setq result + (buffer-substring + (1+ (point)) + (progn (forward-sexp 1) (1- (point)))))) + (t + (forward-char 1)))) + result))) + +(defun ietf-drums-strip (string) + "Remove comments and whitespace from STRING." + (ietf-drums-remove-whitespace (ietf-drums-remove-comments string))) + +(defun ietf-drums-parse-address (string) + "Parse STRING and return a MAILBOX / DISPLAY-NAME pair." + (with-temp-buffer + (let (display-name mailbox c display-string) + (ietf-drums-init string) + (while (not (eobp)) + (setq c (char-after)) + (cond + ((or (eq c ? ) + (eq c ?\t)) + (forward-char 1)) + ((eq c ?\() + (forward-sexp 1)) + ((eq c ?\") + (push (buffer-substring + (1+ (point)) (progn (forward-sexp 1) (1- (point)))) + display-name)) + ((looking-at (concat "[" ietf-drums-atext-token "@" "]")) + (push (buffer-substring (point) (progn (forward-sexp 1) (point))) + display-name)) + ((eq c ?<) + (setq mailbox + (ietf-drums-remove-whitespace + (ietf-drums-remove-comments + (buffer-substring + (1+ (point)) + (progn (forward-sexp 1) (1- (point)))))))) + (t + (forward-char 1)))) + ;; If we found no display-name, then we look for comments. + (if display-name + (setq display-string + (mapconcat 'identity (reverse display-name) " ")) + (setq display-string (ietf-drums-get-comment string))) + (if (not mailbox) + (when (and display-string + (string-match "@" display-string)) + (cons + (mapconcat 'identity (nreverse display-name) "") + (ietf-drums-get-comment string))) + (cons mailbox display-string))))) + +(defun ietf-drums-parse-addresses (string &optional rawp) + "Parse STRING and return a list of MAILBOX / DISPLAY-NAME pairs. +If RAWP, don't actually parse the addresses, but instead return +a list of address strings." + (if (null string) + nil + (with-temp-buffer + (ietf-drums-init string) + (let ((beg (point)) + pairs c address) + (while (not (eobp)) + (setq c (char-after)) + (cond + ((memq c '(?\" ?< ?\()) + (condition-case nil + (forward-sexp 1) + (error + (skip-chars-forward "^,")))) + ((eq c ?,) + (setq address + (if rawp + (buffer-substring beg (point)) + (condition-case nil + (ietf-drums-parse-address + (buffer-substring beg (point))) + (error nil)))) + (if address (push address pairs)) + (forward-char 1) + (setq beg (point))) + (t + (forward-char 1)))) + (setq address + (if rawp + (buffer-substring beg (point)) + (condition-case nil + (ietf-drums-parse-address + (buffer-substring beg (point))) + (error nil)))) + (if address (push address pairs)) + (nreverse pairs))))) + +(defun ietf-drums-unfold-fws () + "Unfold folding white space in the current buffer." + (goto-char (point-min)) + (while (re-search-forward ietf-drums-fws-regexp nil t) + (replace-match " " t t)) + (goto-char (point-min))) + +(defun ietf-drums-parse-date (string) + "Return an Emacs time spec from STRING." + (apply 'encode-time (parse-time-string string))) + +(defun ietf-drums-narrow-to-header () + "Narrow to the header section in the current buffer." + (narrow-to-region + (goto-char (point-min)) + (if (re-search-forward "^\r?$" nil 1) + (match-beginning 0) + (point-max))) + (goto-char (point-min))) + +(defun ietf-drums-quote-string (string) + "Quote string if it needs quoting to be displayed in a header." + (if (string-match (concat "[^" ietf-drums-atext-token "]") string) + (concat "\"" string "\"") + string)) + +(defun ietf-drums-make-address (name address) + (if name + (concat (ietf-drums-quote-string name) " <" address ">") + address)) + +(provide 'ietf-drums) + +;;; ietf-drums.el ends here diff --cc lisp/mail/mail-parse.el index 4fc7e463595,00000000000..546673db6fd mode 100644,000000..100644 --- a/lisp/mail/mail-parse.el +++ b/lisp/mail/mail-parse.el @@@ -1,75 -1,0 +1,75 @@@ +;;; mail-parse.el --- Interface functions for parsing mail + - ;; Copyright (C) 1998-2016 Free Software Foundation, Inc. ++;; Copyright (C) 1998-2017 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This file contains wrapper functions for a wide range of mail +;; parsing functions. The idea is that there are low-level libraries +;; that implement according to various specs (RFC2231, DRUMS, USEFOR), +;; but that programmers that want to parse some header (say, +;; Content-Type) will want to use the latest spec. +;; +;; So while each low-level library (rfc2231.el, for instance) decodes +;; faithfully according to that (proposed) standard, this library is +;; the interface library. If some later RFC supersedes RFC2231, one +;; would just have to write a new low-level library, adjust the +;; aliases in this library, and the users and programmers won't notice +;; any changes. + +;;; Code: + +(require 'mail-prsvr) +(require 'ietf-drums) +(require 'rfc2231) +(require 'rfc2047) +(require 'rfc2045) + +(defalias 'mail-header-parse-content-type 'rfc2231-parse-qp-string) +(defalias 'mail-header-parse-content-disposition 'rfc2231-parse-qp-string) +(defalias 'mail-content-type-get 'rfc2231-get-value) +(defalias 'mail-header-encode-parameter 'rfc2047-encode-parameter) + +(defalias 'mail-header-remove-comments 'ietf-drums-remove-comments) +(defalias 'mail-header-remove-whitespace 'ietf-drums-remove-whitespace) +(defalias 'mail-header-strip 'ietf-drums-strip) +(defalias 'mail-header-get-comment 'ietf-drums-get-comment) +(defalias 'mail-header-parse-address 'ietf-drums-parse-address) +(defalias 'mail-header-parse-addresses 'ietf-drums-parse-addresses) +(defalias 'mail-header-parse-date 'ietf-drums-parse-date) +(defalias 'mail-narrow-to-head 'ietf-drums-narrow-to-header) +(defalias 'mail-quote-string 'ietf-drums-quote-string) +(defalias 'mail-header-make-address 'ietf-drums-make-address) + +(defalias 'mail-header-fold-field 'rfc2047-fold-field) +(defalias 'mail-header-unfold-field 'rfc2047-unfold-field) +(defalias 'mail-header-narrow-to-field 'rfc2047-narrow-to-field) +(defalias 'mail-header-field-value 'rfc2047-field-value) + +(defalias 'mail-encode-encoded-word-region 'rfc2047-encode-region) +(defalias 'mail-encode-encoded-word-buffer 'rfc2047-encode-message-header) +(defalias 'mail-encode-encoded-word-string 'rfc2047-encode-string) +(defalias 'mail-decode-encoded-word-region 'rfc2047-decode-region) +(defalias 'mail-decode-encoded-word-string 'rfc2047-decode-string) +(defalias 'mail-decode-encoded-address-region 'rfc2047-decode-address-region) +(defalias 'mail-decode-encoded-address-string 'rfc2047-decode-address-string) + +(provide 'mail-parse) + +;;; mail-parse.el ends here diff --cc lisp/mail/mail-prsvr.el index 789c0028f64,00000000000..07f650942c0 mode 100644,000000..100644 --- a/lisp/mail/mail-prsvr.el +++ b/lisp/mail/mail-prsvr.el @@@ -1,43 -1,0 +1,43 @@@ +;;; mail-prsvr.el --- Interface variables for parsing mail + - ;; Copyright (C) 1999-2016 Free Software Foundation, Inc. ++;; Copyright (C) 1999-2017 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(defvar mail-parse-charset nil + "Default charset used by low-level libraries. +This variable should never be set. Instead, it should be bound by +functions that wish to call mail-parse functions and let them know +what the desired charset is to be.") + +(defvar mail-parse-mule-charset nil + "Default MULE charset used by low-level libraries. +This variable should never be set.") + +(defvar mail-parse-ignored-charsets nil + "Ignored charsets used by low-level libraries. +This variable should never be set. Instead, it should be bound by +functions that wish to call mail-parse functions and let them know +what the desired charsets is to be ignored.") + +(provide 'mail-prsvr) + +;;; mail-prsvr.el ends here diff --cc lisp/mail/qp.el index a295e0c2d8e,00000000000..262191db4ac mode 100644,000000..100644 --- a/lisp/mail/qp.el +++ b/lisp/mail/qp.el @@@ -1,177 -1,0 +1,177 @@@ +;;; qp.el --- Quoted-Printable functions + - ;; Copyright (C) 1998-2016 Free Software Foundation, Inc. ++;; Copyright (C) 1998-2017 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: mail, extensions + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Functions for encoding and decoding quoted-printable text as +;; defined in RFC 2045. + +;;; Code: + +;;;###autoload +(defun quoted-printable-decode-region (from to &optional coding-system) + "Decode quoted-printable in the region between FROM and TO, per RFC 2045. +If CODING-SYSTEM is non-nil, decode bytes into characters with that +coding-system. + +Interactively, you can supply the CODING-SYSTEM argument +with \\[universal-coding-system-argument]. + +The CODING-SYSTEM argument is a historical hangover and is deprecated. +QP encodes raw bytes and should be decoded into raw bytes. Decoding +them into characters should be done separately." + (interactive + ;; Let the user determine the coding system with "C-x RET c". + (list (region-beginning) (region-end) coding-system-for-read)) + (when (and coding-system + (not (coding-system-p coding-system))) ; e.g. `ascii' from Gnus + (setq coding-system nil)) + (save-excursion + (save-restriction + ;; RFC 2045: ``An "=" followed by two hexadecimal digits, one + ;; or both of which are lowercase letters in "abcdef", is + ;; formally illegal. A robust implementation might choose to + ;; recognize them as the corresponding uppercase letters.'' + (let ((case-fold-search t)) + (narrow-to-region from to) + ;; Do this in case we're called from Gnus, say, in a buffer + ;; which already contains non-ASCII characters which would + ;; then get doubly-decoded below. + (if coding-system + (encode-coding-region (point-min) (point-max) coding-system)) + (goto-char (point-min)) + (while (and (skip-chars-forward "^=") + (not (eobp))) + (cond ((eq (char-after (1+ (point))) ?\n) + (delete-char 2)) + ((looking-at "\\(=[0-9A-F][0-9A-F]\\)+") + ;; Decode this sequence at once; i.e. by a single + ;; deletion and insertion. + (let* ((n (/ (- (match-end 0) (point)) 3)) + (str (make-string n 0))) + (dotimes (i n) + (let ((n1 (char-after (1+ (point)))) + (n2 (char-after (+ 2 (point))))) + (aset str i + (+ (* 16 (- n1 (if (<= n1 ?9) ?0 + (if (<= n1 ?F) (- ?A 10) + (- ?a 10))))) + (- n2 (if (<= n2 ?9) ?0 + (if (<= n2 ?F) (- ?A 10) + (- ?a 10))))))) + (forward-char 3)) + (delete-region (match-beginning 0) (match-end 0)) + (insert str))) + (t + (message "Malformed quoted-printable text") + (forward-char))))) + (if coding-system + (decode-coding-region (point-min) (point-max) coding-system))))) + +(defun quoted-printable-decode-string (string &optional coding-system) + "Decode the quoted-printable encoded STRING and return the result. +If CODING-SYSTEM is non-nil, decode the string with coding-system. +Use of CODING-SYSTEM is deprecated; this function should deal with +raw bytes, and coding conversion should be done separately." + (with-temp-buffer + (set-buffer-multibyte nil) + (insert string) + (quoted-printable-decode-region (point-min) (point-max) coding-system) + (buffer-string))) + +(defun quoted-printable-encode-region (from to &optional fold class) + "Quoted-printable encode the region between FROM and TO per RFC 2045. + +If FOLD, fold long lines at 76 characters (as required by the RFC). +If CLASS is non-nil, translate the characters not matched by that +regexp class, which is in the form expected by `skip-chars-forward'. +You should probably avoid non-ASCII characters in this arg. + +If `mm-use-ultra-safe-encoding' is set, fold lines unconditionally and +encode lines starting with \"From\"." + (interactive "r") + (unless class + ;; Avoid using 8bit characters. = is \075. + ;; Equivalent to "^\000-\007\013\015-\037\200-\377=" + (setq class "\010-\012\014\040-\074\076-\177")) + (save-excursion + (goto-char from) + (if (re-search-forward (string-to-multibyte "[^\x0-\x7f\x80-\xff]") + to t) + (error "Multibyte character in QP encoding region")) + (save-restriction + (narrow-to-region from to) + ;; Encode all the non-ascii and control characters. + (goto-char (point-min)) + (while (and (skip-chars-forward class) + (not (eobp))) + (insert + (prog1 + (format "=%02X" (char-after)) + (delete-char 1)))) + ;; Encode white space at the end of lines. + (goto-char (point-min)) + (while (re-search-forward "[ \t]+$" nil t) + (goto-char (match-beginning 0)) + (while (not (eolp)) + (insert + (prog1 + (format "=%02X" (char-after)) + (delete-char 1))))) + (let ((ultra + (and (boundp 'mm-use-ultra-safe-encoding) + mm-use-ultra-safe-encoding))) + (when (or fold ultra) + (let ((tab-width 1) ; HTAB is one character. + (case-fold-search nil)) + (goto-char (point-min)) + (while (not (eobp)) + ;; In ultra-safe mode, encode "From " at the beginning + ;; of a line. + (when ultra + (if (looking-at "From ") + (replace-match "From=20" nil t) + (if (looking-at "-") + (replace-match "=2D" nil t)))) + (end-of-line) + ;; Fold long lines. + (while (> (current-column) 76) ; tab-width must be 1. + (beginning-of-line) + (forward-char 75) ; 75 chars plus an "=" + (search-backward "=" (- (point) 2) t) + (insert "=\n") + (end-of-line)) + (forward-line)))))))) + +(defun quoted-printable-encode-string (string) + "Encode the STRING as quoted-printable and return the result." + (with-temp-buffer + (if (multibyte-string-p string) + (set-buffer-multibyte 'to) + (set-buffer-multibyte nil)) + (insert string) + (quoted-printable-encode-region (point-min) (point-max)) + (buffer-string))) + +(provide 'qp) + +;;; qp.el ends here diff --cc lisp/mail/rfc2045.el index c2ddf906d06,00000000000..f6000500e11 mode 100644,000000..100644 --- a/lisp/mail/rfc2045.el +++ b/lisp/mail/rfc2045.el @@@ -1,41 -1,0 +1,41 @@@ +;;; rfc2045.el --- Functions for decoding rfc2045 headers + - ;; Copyright (C) 1998-2016 Free Software Foundation, Inc. ++;; Copyright (C) 1998-2017 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;; RFC 2045 is: "Multipurpose Internet Mail Extensions (MIME) Part +;; One: Format of Internet Message Bodies". + +;;; Commentary: + +;;; Code: + +(require 'ietf-drums) + +(defun rfc2045-encode-string (param value) + "Return and PARAM=VALUE string encoded according to RFC2045." + (if (or (string-match (concat "[" ietf-drums-no-ws-ctl-token "]") value) + (string-match (concat "[" ietf-drums-tspecials "]") value) + (string-match "[ \n\t]" value) + (not (string-match (concat "[" ietf-drums-text-token "]") value))) + (concat param "=" (format "%S" value)) + (concat param "=" value))) + +(provide 'rfc2045) + +;;; rfc2045.el ends here diff --cc lisp/mail/rfc2047.el index e636d619c03,00000000000..2a8160921a6 mode 100644,000000..100644 --- a/lisp/mail/rfc2047.el +++ b/lisp/mail/rfc2047.el @@@ -1,1178 -1,0 +1,1178 @@@ +;;; rfc2047.el --- functions for encoding and decoding rfc2047 messages + - ;; Copyright (C) 1998-2016 Free Software Foundation, Inc. ++;; Copyright (C) 1998-2017 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; MORIOKA Tomohiko +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; RFC 2047 is "MIME (Multipurpose Internet Mail Extensions) Part +;; Three: Message Header Extensions for Non-ASCII Text". + +;;; Code: + +(eval-when-compile + (require 'cl)) +(defvar message-posting-charset) + +(require 'mm-util) +(require 'ietf-drums) +;; Fixme: Avoid this (used for mail-parse-charset) mm dependence on gnus. +(require 'mail-prsvr) +(require 'rfc2045) ;; rfc2045-encode-string +(autoload 'mm-body-7-or-8 "mm-bodies") + +(defgroup rfc2047 nil + "RFC2047 messages." + :group 'mail + :prefix "rfc2047-") + +(defcustom rfc2047-header-encoding-alist + '(("Newsgroups" . nil) + ("Followup-To" . nil) + ("Message-ID" . nil) + ("\\(Resent-\\)?\\(From\\|Cc\\|To\\|Bcc\\|\\(In-\\)?Reply-To\\|Sender\ +\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\)" . address-mime) + (t . mime)) + "Header/encoding method alist. +The list is traversed sequentially. The keys can either be +header regexps or t. + +The values can be: + +1) nil, in which case no encoding is done; +2) `mime', in which case the header will be encoded according to RFC2047; +3) `address-mime', like `mime', but takes account of the rules for address + fields (where quoted strings and comments must be treated separately); +4) a charset, in which case it will be encoded as that charset; +5) `default', in which case the field will be encoded as the rest + of the article." + :type '(alist :key-type (choice regexp (const t)) + :value-type (choice (const nil) (const mime) + (const address-mime) + coding-system + (const default)))) + +(defvar rfc2047-charset-encoding-alist + '((us-ascii . nil) + (iso-8859-1 . Q) + (iso-8859-2 . Q) + (iso-8859-3 . Q) + (iso-8859-4 . Q) + (iso-8859-5 . B) + (koi8-r . B) + (iso-8859-7 . B) + (iso-8859-8 . B) + (iso-8859-9 . Q) + (iso-8859-14 . Q) + (iso-8859-15 . Q) + (iso-2022-jp . B) + (iso-2022-kr . B) + (gb2312 . B) + (gbk . B) + (gb18030 . B) + (big5 . B) + (cn-big5 . B) + (cn-gb . B) + (cn-gb-2312 . B) + (euc-kr . B) + (iso-2022-jp-2 . B) + (iso-2022-int-1 . B) + (viscii . Q)) + "Alist of MIME charsets to RFC2047 encodings. +Valid encodings are nil, `Q' and `B'. These indicate binary (no) encoding, +quoted-printable and base64 respectively.") + +(defvar rfc2047-encode-function-alist + '((Q . rfc2047-q-encode-string) + (B . rfc2047-b-encode-string) + (nil . identity)) + "Alist of RFC2047 encodings to encoding functions.") + +(defvar rfc2047-encode-encoded-words t + "Whether encoded words should be encoded again.") + +(defcustom rfc2047-allow-irregular-q-encoded-words t + "Whether to decode irregular Q-encoded words." + :type 'boolean) + +(eval-and-compile ;; Necessary to hard code them in `rfc2047-decode-region'. + (defconst rfc2047-encoded-word-regexp + "=\\?\\([^][\000-\040()<>@,;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\\?\ +\\(B\\?[+/0-9A-Za-z]*=*\ +\\|Q\\?[ ->@-~]*\ +\\)\\?=" + "Regexp that matches encoded word." + ;; The patterns for the B encoding and the Q encoding, i.e. the ones + ;; beginning with "B" and "Q" respectively, are restricted into only + ;; the characters that those encodings may generally use. + ) + (defconst rfc2047-encoded-word-regexp-loose + "=\\?\\([^][\000-\040()<>@,;:*\\\"/?.=]+\\)\\(?:\\*[^?]+\\)?\\?\ +\\(B\\?[+/0-9A-Za-z]*=*\ +\\|Q\\?\\(?:\\?+[ -<>@-~]\\)?\\(?:[ ->@-~]+\\?+[ -<>@-~]\\)*[ ->@-~]*\\?*\ +\\)\\?=" + "Regexp that matches encoded word allowing loose Q encoding." + ;; The pattern for the Q encoding, i.e. the one beginning with "Q", + ;; is similar to: + ;; "Q\\?\\(\\?+[^\n=?]\\)?\\([^\n?]+\\?+[^\n=?]\\)*[^\n?]*\\?*" + ;; <--------1-------><----------2,3----------><--4--><-5-> + ;; They mean: + ;; 1. After "Q?", allow "?"s that follow a character other than "=". + ;; 2. Allow "=" after "Q?"; it isn't regarded as the terminator. + ;; 3. In the middle of an encoded word, allow "?"s that follow a + ;; character other than "=". + ;; 4. Allow any characters other than "?" in the middle of an + ;; encoded word. + ;; 5. At the end, allow "?"s. + )) + +;;; +;;; Functions for encoding RFC2047 messages +;;; + +(defun rfc2047-qp-or-base64 () + "Return the type with which to encode the buffer. +This is either `base64' or `quoted-printable'." + (save-excursion + (let ((limit (min (point-max) (+ 2000 (point-min)))) + (n8bit 0)) + (goto-char (point-min)) + (skip-chars-forward "\x20-\x7f\r\n\t" limit) + (while (< (point) limit) + (incf n8bit) + (forward-char 1) + (skip-chars-forward "\x20-\x7f\r\n\t" limit)) + (if (or (< (* 6 n8bit) (- limit (point-min))) + ;; Don't base64, say, a short line with a single + ;; non-ASCII char when splitting parts by charset. + (= n8bit 1)) + 'quoted-printable + 'base64)))) + +(defun rfc2047-narrow-to-field () + "Narrow the buffer to the header on the current line." + (beginning-of-line) + (narrow-to-region + (point) + (progn + (forward-line 1) + (if (re-search-forward "^[^ \n\t]" nil t) + (point-at-bol) + (point-max)))) + (goto-char (point-min))) + +(defun rfc2047-field-value () + "Return the value of the field at point." + (save-excursion + (save-restriction + (rfc2047-narrow-to-field) + (re-search-forward ":[ \t\n]*" nil t) + (buffer-substring-no-properties (point) (point-max))))) + +(defun rfc2047-quote-special-characters-in-quoted-strings (&optional + encodable-regexp) + "Quote special characters with `\\'s in quoted strings. +Quoting will not be done in a quoted string if it contains characters +matching ENCODABLE-REGEXP or it is within parentheses." + (goto-char (point-min)) + (let ((tspecials (concat "[" ietf-drums-tspecials "]")) + (start (point)) + beg end) + (with-syntax-table (standard-syntax-table) + (while (not (eobp)) + (if (ignore-errors + (forward-list 1) + (eq (char-before) ?\))) + (forward-list -1) + (goto-char (point-max))) + (save-restriction + (narrow-to-region start (point)) + (goto-char start) + (while (search-forward "\"" nil t) + (setq beg (match-beginning 0)) + (unless (eq (char-before beg) ?\\) + (goto-char beg) + (setq beg (1+ beg)) + (condition-case nil + (progn + (forward-sexp) + (setq end (1- (point))) + (goto-char beg) + (if (and encodable-regexp + (re-search-forward encodable-regexp end t)) + (goto-char (1+ end)) + (save-restriction + (narrow-to-region beg end) + (while (re-search-forward tspecials nil 'move) + (if (eq (char-before) ?\\) + (if (looking-at tspecials) ;; Already quoted. + (forward-char) + (insert "\\")) + (goto-char (match-beginning 0)) + (insert "\\") + (forward-char)))) + (forward-char))) + (error + (goto-char beg))))) + (goto-char (point-max))) + (forward-list 1) + (setq start (point)))))) + +(defvar rfc2047-encoding-type 'address-mime + "The type of encoding done by `rfc2047-encode-region'. +This should be dynamically bound around calls to +`rfc2047-encode-region' to either `mime' or `address-mime'. See +`rfc2047-header-encoding-alist', for definitions.") + +(defun rfc2047-encode-message-header () + "Encode the message header according to `rfc2047-header-encoding-alist'. +Should be called narrowed to the head of the message." + (interactive "*") + (save-excursion + (goto-char (point-min)) + (let (alist elem method charsets) + (while (not (eobp)) + (save-restriction + (rfc2047-narrow-to-field) + (setq method nil + alist rfc2047-header-encoding-alist + charsets (mm-find-mime-charset-region (point-min) (point-max))) + ;; M$ Outlook boycotts decoding of a header if it consists + ;; of two or more encoded words and those charsets differ; + ;; it seems to decode all words in a header from a charset + ;; found first in the header. So, we unify the charsets into + ;; a single one used for encoding the whole text in a header. + (let ((mm-coding-system-priorities + (if (= (length charsets) 1) + (cons (mm-charset-to-coding-system (car charsets)) + mm-coding-system-priorities) + mm-coding-system-priorities))) + (while (setq elem (pop alist)) + (when (or (and (stringp (car elem)) + (looking-at (car elem))) + (eq (car elem) t)) + (setq alist nil + method (cdr elem)))) + (if (not (rfc2047-encodable-p)) + (prog2 + (when (eq method 'address-mime) + (rfc2047-quote-special-characters-in-quoted-strings)) + (if (and (eq (mm-body-7-or-8) '8bit) + (mm-multibyte-p) + (mm-coding-system-p + (car message-posting-charset))) + ;; 8 bit must be decoded. + (encode-coding-region + (point-min) (point-max) + (mm-charset-to-coding-system + (car message-posting-charset)))) + ;; No encoding necessary, but folding is nice + (when nil + (rfc2047-fold-region + (save-excursion + (goto-char (point-min)) + (skip-chars-forward "^:") + (when (looking-at ": ") + (forward-char 2)) + (point)) + (point-max)))) + ;; We found something that may perhaps be encoded. + (re-search-forward "^[^:]+: *" nil t) + (cond + ((eq method 'address-mime) + (rfc2047-encode-region (point) (point-max))) + ((eq method 'mime) + (let ((rfc2047-encoding-type 'mime)) + (rfc2047-encode-region (point) (point-max)))) + ((eq method 'default) + (if (and (default-value 'enable-multibyte-characters) + mail-parse-charset) + (encode-coding-region (point) (point-max) + mail-parse-charset))) + ;; We get this when CC'ing messages to newsgroups with + ;; 8-bit names. The group name mail copy just got + ;; unconditionally encoded. Previously, it would ask + ;; whether to encode, which was quite confusing for the + ;; user. If the new behavior is wrong, tell me. I have + ;; left the old code commented out below. + ;; -- Per Abrahamsen Date: 2001-10-07. + ;; Modified by Dave Love, with the commented-out code changed + ;; in accordance with changes elsewhere. + ((null method) + (rfc2047-encode-region (point) (point-max))) +;;; ((null method) +;;; (if (or (message-options-get +;;; 'rfc2047-encode-message-header-encode-any) +;;; (message-options-set +;;; 'rfc2047-encode-message-header-encode-any +;;; (y-or-n-p +;;; "Some texts are not encoded. Encode anyway?"))) +;;; (rfc2047-encode-region (point-min) (point-max)) +;;; (error "Cannot send unencoded text"))) + ((mm-coding-system-p method) + (when (default-value 'enable-multibyte-characters) + (encode-coding-region (point) (point-max) method))) + ;; Hm. + (t))) + (goto-char (point-max)))))))) + +;; Fixme: This, and the require below may not be the Right Thing, but +;; should be safe just before release. -- fx 2001-02-08 + +(defun rfc2047-encodable-p () + "Return non-nil if any characters in current buffer need encoding in headers. +The buffer may be narrowed." + (require 'message) ; for message-posting-charset + (let ((charsets + (mm-find-mime-charset-region (point-min) (point-max)))) + (goto-char (point-min)) + (or (and rfc2047-encode-encoded-words + (prog1 + (re-search-forward rfc2047-encoded-word-regexp nil t) + (goto-char (point-min)))) + (and charsets + (not (equal charsets (list (car message-posting-charset)))))))) + +;; Use this syntax table when parsing into regions that may need +;; encoding. Double quotes are string delimiters, backslash is +;; character quoting, and all other RFC 2822 special characters are +;; treated as punctuation so we can use forward-sexp/forward-word to +;; skip to the end of regions appropriately. Nb. ietf-drums does +;; things differently. +(defconst rfc2047-syntax-table + ;; (make-char-table 'syntax-table '(2)) only works in Emacs. + (let ((table (make-syntax-table))) + ;; The following is done to work for setting all elements of the table; + ;; it appears to be the cleanest way. + ;; Play safe and don't assume the form of the word syntax entry -- + ;; copy it from ?a. + (set-char-table-range table t (aref (standard-syntax-table) ?a)) + (modify-syntax-entry ?\\ "\\" table) + (modify-syntax-entry ?\" "\"" table) + (modify-syntax-entry ?\( "(" table) + (modify-syntax-entry ?\) ")" table) + (modify-syntax-entry ?\< "." table) + (modify-syntax-entry ?\> "." table) + (modify-syntax-entry ?\[ "." table) + (modify-syntax-entry ?\] "." table) + (modify-syntax-entry ?: "." table) + (modify-syntax-entry ?\; "." table) + (modify-syntax-entry ?, "." table) + (modify-syntax-entry ?@ "." table) + table)) + +(defun rfc2047-encode-region (b e &optional dont-fold) + "Encode words in region B to E that need encoding. +By default, the region is treated as containing RFC2822 addresses. +Dynamically bind `rfc2047-encoding-type' to change that." + (save-restriction + (narrow-to-region b e) + (let ((encodable-regexp (if rfc2047-encode-encoded-words + "[^\000-\177]+\\|=\\?" + "[^\000-\177]+")) + start ; start of current token + end begin csyntax + ;; Whether there's an encoded word before the current token, + ;; either immediately or separated by space. + last-encoded + (orig-text (buffer-substring-no-properties b e))) + (if (eq 'mime rfc2047-encoding-type) + ;; Simple case. Continuous words in which all those contain + ;; non-ASCII characters are encoded collectively. Encoding + ;; ASCII words, including `Re:' used in Subject headers, is + ;; avoided for interoperability with non-MIME clients and + ;; for making it easy to find keywords. + (progn + (goto-char (point-min)) + (while (progn (skip-chars-forward " \t\n") + (not (eobp))) + (setq start (point)) + (while (and (looking-at "[ \t\n]*\\([^ \t\n]+\\)") + (progn + (setq end (match-end 0)) + (re-search-forward encodable-regexp end t))) + (goto-char end)) + (if (> (point) start) + (rfc2047-encode start (point)) + (goto-char end)))) + ;; `address-mime' case -- take care of quoted words, comments. + (rfc2047-quote-special-characters-in-quoted-strings encodable-regexp) + (with-syntax-table rfc2047-syntax-table + (goto-char (point-min)) + (condition-case err ; in case of unbalanced quotes + ;; Look for rfc2822-style: sequences of atoms, quoted + ;; strings, specials, whitespace. (Specials mustn't be + ;; encoded.) + (while (not (eobp)) + ;; Skip whitespace. + (skip-chars-forward " \t\n") + (setq start (point)) + (cond + ((not (char-after))) ; eob + ;; else token start + ((eq ?\" (setq csyntax (char-syntax (char-after)))) + ;; Quoted word. + (forward-sexp) + (setq end (point)) + ;; Does it need encoding? + (goto-char start) + (if (re-search-forward encodable-regexp end 'move) + ;; It needs encoding. Strip the quotes first, + ;; since encoded words can't occur in quotes. + (progn + (goto-char end) + (delete-char -1) + (goto-char start) + (delete-char 1) + (when last-encoded + ;; There was a preceding quoted word. We need + ;; to include any separating whitespace in this + ;; word to avoid it getting lost. + (skip-chars-backward " \t") + ;; A space is needed between the encoded words. + (insert ? ) + (setq start (point) + end (1+ end))) + ;; Adjust the end position for the deleted quotes. + (rfc2047-encode start (- end 2)) + (setq last-encoded t)) ; record that it was encoded + (setq last-encoded nil))) + ((eq ?. csyntax) + ;; Skip other delimiters, but record that they've + ;; potentially separated quoted words. + (forward-char) + (setq last-encoded nil)) + ((eq ?\) csyntax) + (error "Unbalanced parentheses")) + ((eq ?\( csyntax) + ;; Look for the end of parentheses. + (forward-list) + ;; Encode text as an unstructured field. + (let ((rfc2047-encoding-type 'mime)) + (rfc2047-encode-region (1+ start) (1- (point)))) + (skip-chars-forward ")")) + (t ; normal token/whitespace sequence + ;; Find the end. + ;; Skip one ASCII word, or encode continuous words + ;; in which all those contain non-ASCII characters. + (setq end nil) + (while (not (or end (eobp))) + (when (looking-at "[\000-\177]+") + (setq begin (point) + end (match-end 0)) + (when (progn + (while (and (or (re-search-forward + "[ \t\n]\\|\\Sw" end 'move) + (setq end nil)) + (eq ?\\ (char-syntax (char-before)))) + ;; Skip backslash-quoted characters. + (forward-char)) + end) + (setq end (match-beginning 0)) + (if rfc2047-encode-encoded-words + (progn + (goto-char begin) + (when (search-forward "=?" end 'move) + (goto-char (match-beginning 0)) + (setq end nil))) + (goto-char end)))) + ;; Where the value nil of `end' means there may be + ;; text to have to be encoded following the point. + ;; Otherwise, the point reached to the end of ASCII + ;; words separated by whitespace or a special char. + (unless end + (when (looking-at encodable-regexp) + (goto-char (setq begin (match-end 0))) + (while (and (looking-at "[ \t\n]+\\([^ \t\n]+\\)") + (setq end (match-end 0)) + (progn + (while (re-search-forward + encodable-regexp end t)) + (< begin (point))) + (goto-char begin) + (or (not (re-search-forward "\\Sw" end t)) + (progn + (goto-char (match-beginning 0)) + nil))) + (goto-char end)) + (when (looking-at "[^ \t\n]+") + (setq end (match-end 0)) + (if (re-search-forward "\\Sw+" end t) + ;; There are special characters better + ;; to be encoded so that MTAs may parse + ;; them safely. + (cond ((= end (point))) + ((looking-at (concat "\\sw*\\(" + encodable-regexp + "\\)")) + (setq end nil)) + (t + (goto-char (1- (match-end 0))) + (unless (= (point) (match-beginning 0)) + ;; Separate encodable text and + ;; delimiter. + (insert " ")))) + (goto-char end) + (skip-chars-forward " \t\n") + (if (and (looking-at "[^ \t\n]+") + (string-match encodable-regexp + (match-string 0))) + (setq end nil) + (goto-char end))))))) + (skip-chars-backward " \t\n") + (setq end (point)) + (goto-char start) + (if (re-search-forward encodable-regexp end 'move) + (progn + (unless (memq (char-before start) '(nil ?\t ? )) + (if (progn + (goto-char start) + (skip-chars-backward "^ \t\n") + (and (looking-at "\\Sw+") + (= (match-end 0) start))) + ;; Also encode bogus delimiters. + (setq start (point)) + ;; Separate encodable text and delimiter. + (goto-char start) + (insert " ") + (setq start (1+ start) + end (1+ end)))) + (rfc2047-encode start end) + (setq last-encoded t)) + (setq last-encoded nil))))) + (error + (if (or debug-on-quit debug-on-error) + (signal (car err) (cdr err)) + (error "Invalid data for rfc2047 encoding: %s" + (replace-regexp-in-string "[ \t\n]+" " " orig-text)))))))) + (unless dont-fold + (rfc2047-fold-region b (point))) + (goto-char (point-max)))) + +(defun rfc2047-encode-string (string &optional dont-fold) + "Encode words in STRING. +By default, the string is treated as containing addresses (see +`rfc2047-encoding-type')." + (mm-with-multibyte-buffer + (insert string) + (rfc2047-encode-region (point-min) (point-max) dont-fold) + (buffer-string))) + +;; From RFC 2047: +;; 2. Syntax of encoded-words +;; [...] +;; While there is no limit to the length of a multiple-line header +;; field, each line of a header field that contains one or more +;; 'encoded-word's is limited to 76 characters. +;; +;; In `rfc2047-encode-parameter' it is bound to nil, so don't defconst it. +(defvar rfc2047-encode-max-chars 76 + "Maximum characters of each header line that contain encoded-words. +According to RFC 2047, it is 76. If it is nil, encoded-words +will not be folded. Too small value may cause an error. You +should not change this value.") + +(defun rfc2047-encode-1 (column string cs encoder start crest tail + &optional eword) + "Subroutine used by `rfc2047-encode'." + (cond ((string-equal string "") + (or eword "")) + ((not rfc2047-encode-max-chars) + (concat start + (funcall encoder (if cs + (encode-coding-string string cs) + string)) + "?=")) + ((>= column rfc2047-encode-max-chars) + (when eword + (cond ((string-match "\n[ \t]+\\'" eword) + ;; Remove a superfluous empty line. + (setq eword (substring eword 0 (match-beginning 0)))) + ((string-match "(+\\'" eword) + ;; Break the line before the open parenthesis. + (setq crest (concat crest (match-string 0 eword)) + eword (substring eword 0 (match-beginning 0)))))) + (rfc2047-encode-1 (length crest) string cs encoder start " " tail + (concat eword "\n" crest))) + (t + (let ((index 0) + (limit (1- (length string))) + (prev "") + next len) + (while (and prev + (<= index limit)) + (setq next (concat start + (funcall encoder + (if cs + (encode-coding-string + (substring string 0 (1+ index)) + cs) + (substring string 0 (1+ index)))) + "?=") + len (+ column (length next))) + (if (> len rfc2047-encode-max-chars) + (setq next prev + prev nil) + (if (or (< index limit) + (<= (+ len (or (string-match "\n" tail) + (length tail))) + rfc2047-encode-max-chars)) + (setq prev next + index (1+ index)) + (if (string-match "\\`)+" tail) + ;; Break the line after the close parenthesis. + (setq tail (concat (substring tail 0 (match-end 0)) + "\n " + (substring tail (match-end 0))) + prev next + index (1+ index)) + (setq next prev + prev nil))))) + (if (> index limit) + (concat eword next tail) + (if (= 0 index) + (if (and eword + (string-match "(+\\'" eword)) + (setq crest (concat crest (match-string 0 eword)) + eword (substring eword 0 (match-beginning 0))) + (setq eword (concat eword next))) + (setq crest " " + eword (concat eword next))) + (when (string-match "\n[ \t]+\\'" eword) + ;; Remove a superfluous empty line. + (setq eword (substring eword 0 (match-beginning 0)))) + (rfc2047-encode-1 (length crest) (substring string index) + cs encoder start " " tail + (concat eword "\n" crest))))))) + +(defun rfc2047-encode (b e) + "Encode the word(s) in the region B to E. +Point moves to the end of the region." + (let ((mime-charset (or (mm-find-mime-charset-region b e) (list 'us-ascii))) + cs encoding tail crest eword) + ;; Use utf-8 as a last resort if determining charset of text fails. + (if (memq nil mime-charset) + (setq mime-charset (list 'utf-8))) + (cond ((> (length mime-charset) 1) + (error "Can't rfc2047-encode `%s'" + (buffer-substring-no-properties b e))) + ((= (length mime-charset) 1) + (setq mime-charset (car mime-charset) + cs (mm-charset-to-coding-system mime-charset)) + (unless (and (mm-multibyte-p) + (mm-coding-system-p cs)) + (setq cs nil)) + (save-restriction + (narrow-to-region b e) + (setq encoding + (or (cdr (assq mime-charset + rfc2047-charset-encoding-alist)) + ;; For the charsets that don't have a preferred + ;; encoding, choose the one that's shorter. + (if (eq (rfc2047-qp-or-base64) 'base64) + 'B + 'Q))) + (widen) + (goto-char e) + (skip-chars-forward "^ \t\n") + ;; `tail' may contain a close parenthesis. + (setq tail (buffer-substring-no-properties e (point))) + (goto-char b) + (setq b (point-marker) + e (set-marker (make-marker) e)) + (rfc2047-fold-region (point-at-bol) b) + (goto-char b) + (skip-chars-backward "^ \t\n") + (unless (= 0 (skip-chars-backward " \t")) + ;; `crest' may contain whitespace and an open parenthesis. + (setq crest (buffer-substring-no-properties (point) b))) + (setq eword (rfc2047-encode-1 + (- b (point-at-bol)) + (replace-regexp-in-string + "\n\\([ \t]?\\)" "\\1" + (buffer-substring-no-properties b e)) + cs + (or (cdr (assq encoding + rfc2047-encode-function-alist)) + 'identity) + (concat "=?" (downcase (symbol-name mime-charset)) + "?" (upcase (symbol-name encoding)) "?") + (or crest " ") + tail)) + (delete-region (if (eq (aref eword 0) ?\n) + (if (bolp) + ;; The line was folded before encoding. + (1- (point)) + (point)) + (goto-char b)) + (+ e (length tail))) + ;; `eword' contains `crest' and `tail'. + (insert eword) + (set-marker b nil) + (set-marker e nil) + (unless (or (/= 0 (length tail)) + (eobp) + (looking-at "[ \t\n)]")) + (insert " ")))) + (t + (goto-char e))))) + +(defun rfc2047-fold-field () + "Fold the current header field." + (save-excursion + (save-restriction + (rfc2047-narrow-to-field) + (rfc2047-fold-region (point-min) (point-max))))) + +(defun rfc2047-fold-region (b e) + "Fold long lines in region B to E." + (save-restriction + (narrow-to-region b e) + (goto-char (point-min)) + (let ((break nil) + (qword-break nil) + (first t) + (bol (save-restriction + (widen) + (point-at-bol)))) + (while (not (eobp)) + (when (and (or break qword-break) + (> (- (point) bol) 76)) + (goto-char (or break qword-break)) + (setq break nil + qword-break nil) + (skip-chars-backward " \t") + (if (looking-at "[ \t]") + (insert ?\n) + (insert "\n ")) + (setq bol (1- (point))) + ;; Don't break before the first non-LWSP characters. + (skip-chars-forward " \t") + (unless (eobp) + (forward-char 1))) + (cond + ((eq (char-after) ?\n) + (forward-char 1) + (setq bol (point) + break nil + qword-break nil) + (skip-chars-forward " \t") + (unless (or (eobp) (eq (char-after) ?\n)) + (forward-char 1))) + ((eq (char-after) ?\r) + (forward-char 1)) + ((memq (char-after) '(? ?\t)) + (skip-chars-forward " \t") + (unless first ;; Don't break just after the header name. + (setq break (point)))) + ((not break) + (if (not (looking-at "=\\?[^=]")) + (if (eq (char-after) ?=) + (forward-char 1) + (skip-chars-forward "^ \t\n\r=")) + ;; Don't break at the start of the field. + (unless (= (point) b) + (setq qword-break (point))) + (skip-chars-forward "^ \t\n\r"))) + (t + (skip-chars-forward "^ \t\n\r"))) + (setq first nil)) + (when (and (or break qword-break) + (> (- (point) bol) 76)) + (goto-char (or break qword-break)) + (setq break nil + qword-break nil) + (if (or (> 0 (skip-chars-backward " \t")) + (looking-at "[ \t]")) + (insert ?\n) + (insert "\n ")) + (setq bol (1- (point))) + ;; Don't break before the first non-LWSP characters. + (skip-chars-forward " \t") + (unless (eobp) + (forward-char 1)))))) + +(defun rfc2047-unfold-field () + "Fold the current line." + (save-excursion + (save-restriction + (rfc2047-narrow-to-field) + (rfc2047-unfold-region (point-min) (point-max))))) + +(defun rfc2047-unfold-region (b e) + "Unfold lines in region B to E." + (save-restriction + (narrow-to-region b e) + (goto-char (point-min)) + (let ((bol (save-restriction + (widen) + (point-at-bol))) + (eol (point-at-eol))) + (forward-line 1) + (while (not (eobp)) + (if (and (looking-at "[ \t]") + (< (- (point-at-eol) bol) 76)) + (delete-region eol (progn + (goto-char eol) + (skip-chars-forward "\r\n") + (point))) + (setq bol (point-at-bol))) + (setq eol (point-at-eol)) + (forward-line 1))))) + +(defun rfc2047-b-encode-string (string) + "Base64-encode the header contained in STRING." + (base64-encode-string string t)) + +(autoload 'quoted-printable-encode-region "qp") + +(defun rfc2047-q-encode-string (string) + "Quoted-printable-encode the header in STRING." + (mm-with-unibyte-buffer + (insert string) + (quoted-printable-encode-region + (point-min) (point-max) nil + ;; = (\075), _ (\137), ? (\077) are used in the encoded word. + ;; Avoid using 8bit characters. + ;; This list excludes `especials' (see the RFC2047 syntax), + ;; meaning that some characters in non-structured fields will + ;; get encoded when they con't need to be. The following is + ;; what it used to be. + ;;; ;; Equivalent to "^\000-\007\011\013\015-\037\200-\377=_?" + ;;; "\010\012\014\040-\074\076\100-\136\140-\177") + "-\b\n\f !#-'*+0-9A-Z\\^`-~\d") + (subst-char-in-region (point-min) (point-max) ? ?_) + (buffer-string))) + +(defun rfc2047-encode-parameter (param value) + "Return and PARAM=VALUE string encoded in the RFC2047-like style. +This is a substitution for the `rfc2231-encode-string' function, that +is the standard but many mailers don't support it." + (let ((rfc2047-encoding-type 'mime) + (rfc2047-encode-max-chars nil)) + (rfc2045-encode-string param (rfc2047-encode-string value t)))) + +;;; +;;; Functions for decoding RFC2047 messages +;;; + +(defvar rfc2047-quote-decoded-words-containing-tspecials nil + "If non-nil, quote decoded words containing special characters.") + +(defcustom rfc2047-allow-incomplete-encoded-text t + "Non-nil means allow incomplete encoded-text in successive encoded-words. +Dividing of encoded-text in the place other than character boundaries +violates RFC2047 section 5, while we have a capability to decode it. +If it is non-nil, the decoder will decode B- or Q-encoding in each +encoded-word, concatenate them, and decode it by charset. Otherwise, +the decoder will fully decode each encoded-word before concatenating +them." + :type 'boolean) + +(defun rfc2047-strip-backslashes-in-quoted-strings () + "Strip backslashes in quoted strings. `\\\"' remains." + (goto-char (point-min)) + (let (beg) + (with-syntax-table (standard-syntax-table) + (while (search-forward "\"" nil t) + (unless (eq (char-before) ?\\) + (setq beg (match-end 0)) + (goto-char (match-beginning 0)) + (condition-case nil + (progn + (forward-sexp) + (save-restriction + (narrow-to-region beg (1- (point))) + (goto-char beg) + (while (search-forward "\\" nil 'move) + (unless (memq (char-after) '(?\")) + (delete-char -1)) + (forward-char))) + (forward-char)) + (error + (goto-char beg)))))))) + +(defun rfc2047-charset-to-coding-system (charset &optional allow-override) + "Return coding-system corresponding to MIME CHARSET. +If your Emacs implementation can't decode CHARSET, return nil. + +If allow-override is given, use `mm-charset-override-alist' to +map undesired charset names to their replacement. This should +only be used for decoding, not for encoding." + (when (stringp charset) + (setq charset (intern (downcase charset)))) + (when (or (not charset) + (eq 'gnus-all mail-parse-ignored-charsets) + (memq 'gnus-all mail-parse-ignored-charsets) + (memq charset mail-parse-ignored-charsets)) + (setq charset mail-parse-charset)) + (let ((cs (mm-charset-to-coding-system charset nil allow-override))) + (cond ((eq cs 'ascii) + (setq cs (or (mm-charset-to-coding-system mail-parse-charset) + 'raw-text))) + ((mm-coding-system-p cs)) + ((and charset + (listp mail-parse-ignored-charsets) + (memq 'gnus-unknown mail-parse-ignored-charsets)) + (setq cs (mm-charset-to-coding-system mail-parse-charset)))) + (if (eq cs 'ascii) + 'raw-text + cs))) + +(autoload 'quoted-printable-decode-string "qp") + +(defun rfc2047-decode-encoded-words (words) + "Decode successive encoded-words in WORDS and return a decoded string. +Each element of WORDS looks like (CHARSET ENCODING ENCODED-TEXT +ENCODED-WORD)." + (let (word charset cs encoding text rest) + (while words + (setq word (pop words)) + (if (and (setq cs (rfc2047-charset-to-coding-system + (setq charset (car word)) t)) + (condition-case code + (cond ((char-equal ?B (nth 1 word)) + (setq text (base64-decode-string + (rfc2047-pad-base64 (nth 2 word))))) + ((char-equal ?Q (nth 1 word)) + (setq text (quoted-printable-decode-string + (subst-char-in-string + ?_ ? (nth 2 word) t))))) + (error + (message "%s" (error-message-string code)) + nil))) + (if (and rfc2047-allow-incomplete-encoded-text + (eq cs (caar rest))) + ;; Concatenate text of which the charset is the same. + (setcdr (car rest) (concat (cdar rest) text)) + (push (cons cs text) rest)) + ;; Don't decode encoded-word. + (push (cons nil (nth 3 word)) rest))) + (while rest + (setq words (concat + (or (and (setq cs (caar rest)) + (condition-case code + (decode-coding-string (cdar rest) cs) + (error + (message "%s" (error-message-string code)) + nil))) + (concat (when (cdr rest) " ") + (cdar rest) + (when (and words + (not (eq (string-to-char words) ? ))) + " "))) + words) + rest (cdr rest))) + words)) + +;; Fixme: This should decode in place, not cons intermediate strings. +;; Also check whether it needs to worry about delimiting fields like +;; encoding. + +;; In fact it's reported that (invalid) encoding of mailboxes in +;; addr-specs is in use, so delimiting fields might help. Probably +;; not decoding a word which isn't properly delimited is good enough +;; and worthwhile (is it more correct or not?), e.g. something like +;; `=?iso-8859-1?q?foo?=@'. + +(defun rfc2047-decode-region (start end &optional address-mime) + "Decode MIME-encoded words in region between START and END. +If ADDRESS-MIME is non-nil, strip backslashes which precede characters +other than `\"' and `\\' in quoted strings." + (interactive "r") + (let ((case-fold-search t) + (eword-regexp + (if rfc2047-allow-irregular-q-encoded-words + (eval-when-compile + (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp-loose "\\)")) + (eval-when-compile + (concat "[\n\t ]*\\(" rfc2047-encoded-word-regexp "\\)")))) + b e match words) + (save-excursion + (save-restriction + (narrow-to-region start end) + (when address-mime + (rfc2047-strip-backslashes-in-quoted-strings)) + (goto-char (setq b start)) + ;; Look for the encoded-words. + (while (setq match (re-search-forward eword-regexp nil t)) + (setq e (match-beginning 1) + end (match-end 0) + words nil) + (while match + (push (list (match-string 2) ;; charset + (char-after (match-beginning 3)) ;; encoding + (substring (match-string 3) 2) ;; encoded-text + (match-string 1)) ;; encoded-word + words) + ;; Look for the subsequent encoded-words. + (when (setq match (looking-at eword-regexp)) + (goto-char (setq end (match-end 0))))) + ;; Replace the encoded-words with the decoded one. + (delete-region e end) + (insert (rfc2047-decode-encoded-words (nreverse words))) + (save-restriction + (narrow-to-region e (point)) + (goto-char e) + ;; Remove newlines between decoded words, though such + ;; things essentially must not be there. + (while (re-search-forward "[\n\r]+" nil t) + (replace-match " ")) + (setq end (point-max)) + ;; Quote decoded words if there are special characters + ;; which might violate RFC2822. + (when (and rfc2047-quote-decoded-words-containing-tspecials + (let ((regexp (car (rassq + 'address-mime + rfc2047-header-encoding-alist)))) + (when regexp + (save-restriction + (widen) + (and + ;; Don't quote words if already quoted. + (not (and (eq (char-before e) ?\") + (eq (char-after end) ?\"))) + (progn + (beginning-of-line) + (while (and (memq (char-after) '(? ?\t)) + (zerop (forward-line -1)))) + (looking-at regexp))))))) + (let (quoted) + (goto-char e) + (skip-chars-forward " \t") + (setq start (point)) + (setq quoted (eq (char-after) ?\")) + (goto-char (point-max)) + (skip-chars-backward " \t" start) + (if (setq quoted (and quoted + (> (point) (1+ start)) + (eq (char-before) ?\"))) + (progn + (backward-char) + (setq start (1+ start) + end (point-marker))) + (setq end (point-marker))) + (goto-char start) + (while (search-forward "\"" end t) + (when (prog2 + (backward-char) + (zerop (% (skip-chars-backward "\\\\") 2)) + (goto-char (match-beginning 0))) + (insert "\\")) + (forward-char)) + (when (and (not quoted) + (progn + (goto-char start) + (re-search-forward + (concat "[" ietf-drums-tspecials "]") + end t))) + (goto-char start) + (insert "\"") + (goto-char end) + (insert "\"")) + (set-marker end nil))) + (goto-char (point-max))) + (when (and (mm-multibyte-p) + mail-parse-charset + (not (eq mail-parse-charset 'us-ascii)) + (not (eq mail-parse-charset 'gnus-decoded))) + (decode-coding-region b e mail-parse-charset)) + (setq b (point))) + (when (and (mm-multibyte-p) + mail-parse-charset + (not (eq mail-parse-charset 'us-ascii)) + (not (eq mail-parse-charset 'gnus-decoded))) + (decode-coding-region b (point-max) mail-parse-charset)))))) + +(defun rfc2047-decode-address-region (start end) + "Decode MIME-encoded words in region between START and END. +Backslashes which precede characters other than `\"' and `\\' in quoted +strings are stripped." + (rfc2047-decode-region start end t)) + +(defun rfc2047-decode-string (string &optional address-mime) + "Decode MIME-encoded STRING and return the result. +If ADDRESS-MIME is non-nil, strip backslashes which precede characters +other than `\"' and `\\' in quoted strings." + (if (string-match "=\\?" string) + (with-temp-buffer + ;; We used to only call mm-enable-multibyte if `m' is non-nil, + ;; but this can't be the right criterion. Don't just revert this + ;; change if it encounters a bug. Please help me fix it + ;; right instead. --Stef + ;; The string returned should always be multibyte in a multibyte + ;; session, i.e. the buffer should be multibyte before + ;; `buffer-string' is called. + (mm-enable-multibyte) + (insert string) + (inline + (rfc2047-decode-region (point-min) (point-max) address-mime)) + (buffer-string)) + (when address-mime + (setq string + (with-temp-buffer + (when (multibyte-string-p string) + (mm-enable-multibyte)) + (insert string) + (rfc2047-strip-backslashes-in-quoted-strings) + (buffer-string)))) + ;; Fixme: As above, `m' here is inappropriate. + (if (and ;; m + mail-parse-charset + (not (eq mail-parse-charset 'us-ascii)) + (not (eq mail-parse-charset 'gnus-decoded))) + ;; `decode-coding-string' in Emacs offers a third optional + ;; arg NOCOPY to avoid consing a new string if the decoding + ;; is "trivial". Unfortunately it currently doesn't + ;; consider anything else than a nil coding system + ;; trivial. + ;; `rfc2047-decode-string' is called multiple times for each + ;; article during summary buffer generation, and we really + ;; want to avoid unnecessary consing. So we bypass + ;; `decode-coding-string' if the string is purely ASCII. + (if (eq (detect-coding-string string t) 'undecided) + ;; string is purely ASCII + string + (decode-coding-string string mail-parse-charset)) + (string-to-multibyte string)))) + +(defun rfc2047-decode-address-string (string) + "Decode MIME-encoded STRING and return the result. +Backslashes which precede characters other than `\"' and `\\' in quoted +strings are stripped." + (rfc2047-decode-string string t)) + +(defun rfc2047-pad-base64 (string) + "Pad STRING to quartets." + ;; Be more liberal to accept buggy base64 strings. If + ;; base64-decode-string accepts buggy strings, this function could + ;; be aliased to identity. + (if (= 0 (mod (length string) 4)) + string + (when (string-match "=+$" string) + (setq string (substring string 0 (match-beginning 0)))) + (case (mod (length string) 4) + (0 string) + (1 string) ;; Error, don't pad it. + (2 (concat string "==")) + (3 (concat string "="))))) + +(provide 'rfc2047) + +;;; rfc2047.el ends here diff --cc lisp/mail/rfc2231.el index 128779ab4c6,00000000000..ba972c73460 mode 100644,000000..100644 --- a/lisp/mail/rfc2231.el +++ b/lisp/mail/rfc2231.el @@@ -1,308 -1,0 +1,308 @@@ +;;; rfc2231.el --- Functions for decoding rfc2231 headers + - ;; Copyright (C) 1998-2016 Free Software Foundation, Inc. ++;; Copyright (C) 1998-2017 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'ietf-drums) +(require 'rfc2047) +(autoload 'mm-encode-body "mm-bodies") +(autoload 'mail-header-remove-whitespace "mail-parse") +(autoload 'mail-header-remove-comments "mail-parse") + +(defun rfc2231-get-value (ct attribute) + "Return the value of ATTRIBUTE from CT." + (cdr (assq attribute (cdr ct)))) + +(defun rfc2231-parse-qp-string (string) + "Parse QP-encoded string using `rfc2231-parse-string'. +N.B. This is in violation with RFC2047, but it seem to be in common use." + (rfc2231-parse-string (rfc2047-decode-string string))) + +(defun rfc2231-parse-string (string &optional signal-error) + "Parse STRING and return a list. +The list will be on the form + `(name (attribute . value) (attribute . value)...)'. + +If the optional SIGNAL-ERROR is non-nil, signal an error when this +function fails in parsing of parameters. Otherwise, this function +must never cause a Lisp error." + (with-temp-buffer + (let ((ttoken (ietf-drums-token-to-list ietf-drums-text-token)) + (stoken (ietf-drums-token-to-list ietf-drums-tspecials)) + (ntoken (ietf-drums-token-to-list "0-9")) + c type attribute encoded number parameters value) + (ietf-drums-init + (condition-case nil + (mail-header-remove-whitespace + (mail-header-remove-comments string)) + ;; The most likely cause of an error is unbalanced parentheses + ;; or double-quotes. If all parentheses and double-quotes are + ;; quoted meaninglessly with backslashes, removing them might + ;; make it parsable. Let's try... + (error + (let (mod) + (when (and (string-match "\\\\\"" string) + (not (string-match "\\`\"\\|[^\\]\"" string))) + (setq string (replace-regexp-in-string "\\\\\"" "\"" string) + mod t)) + (when (and (string-match "\\\\(" string) + (string-match "\\\\)" string) + (not (string-match "\\`(\\|[^\\][()]" string))) + (setq string (replace-regexp-in-string + "\\\\\\([()]\\)" "\\1" string) + mod t)) + (or (and mod + (ignore-errors + (mail-header-remove-whitespace + (mail-header-remove-comments string)))) + ;; Finally, attempt to extract only type. + (if (string-match + (concat "\\`[\t\n ]*\\([^" ietf-drums-tspecials "\t\n ]+" + "\\(?:/[^" ietf-drums-tspecials + "\t\n ]+\\)?\\)\\(?:[\t\n ;]\\|\\'\\)") + string) + (match-string 1 string) + "")))))) + (let ((table (copy-syntax-table ietf-drums-syntax-table))) + (modify-syntax-entry ?\' "w" table) + (modify-syntax-entry ?* " " table) + (modify-syntax-entry ?\; " " table) + (modify-syntax-entry ?= " " table) + ;; The following isn't valid, but one should be liberal + ;; in what one receives. + (modify-syntax-entry ?\: "w" table) + (set-syntax-table table)) + (setq c (char-after)) + (when (and (memq c ttoken) + (not (memq c stoken)) + (setq type (ignore-errors + (downcase + (buffer-substring (point) (progn + (forward-sexp 1) + (point))))))) + ;; Do the params + (condition-case err + (progn + (while (not (eobp)) + (setq c (char-after)) + (unless (eq c ?\;) + (error "Invalid header: %s" string)) + (forward-char 1) + ;; If c in nil, then this is an invalid header, but + ;; since elm generates invalid headers on this form, + ;; we allow it. + (when (setq c (char-after)) + (if (and (memq c ttoken) + (not (memq c stoken))) + (setq attribute + (intern + (downcase + (buffer-substring + (point) (progn (forward-sexp 1) (point)))))) + (error "Invalid header: %s" string)) + (setq c (char-after)) + (if (eq c ?*) + (progn + (forward-char 1) + (setq c (char-after)) + (if (not (memq c ntoken)) + (setq encoded t + number nil) + (setq number + (string-to-number + (buffer-substring + (point) (progn (forward-sexp 1) (point))))) + (setq c (char-after)) + (when (eq c ?*) + (setq encoded t) + (forward-char 1) + (setq c (char-after))))) + (setq number nil + encoded nil)) + (unless (eq c ?=) + (error "Invalid header: %s" string)) + (forward-char 1) + (setq c (char-after)) + (cond + ((eq c ?\") + (setq value (buffer-substring (1+ (point)) + (progn + (forward-sexp 1) + (1- (point))))) + (when encoded + (setq value (mapconcat (lambda (c) (format "%%%02x" c)) + value "")))) + ((and (or (memq c ttoken) + ;; EXTENSION: Support non-ascii chars. + (> c ?\177)) + (not (memq c stoken))) + (setq value + (buffer-substring + (point) + (progn + ;; Jump over asterisk, non-ASCII + ;; and non-boundary characters. + (while (and c + (or (eq c ?*) + (> c ?\177) + (not (eq (char-syntax c) ? )))) + (forward-char 1) + (setq c (char-after))) + (point))))) + (t + (error "Invalid header: %s" string))) + (push (list attribute value number encoded) + parameters)))) + (error + (setq parameters nil) + (when signal-error + (signal (car err) (cdr err))))) + + ;; Now collect and concatenate continuation parameters. + (let ((cparams nil) + elem) + (loop for (attribute value part encoded) + in (sort parameters (lambda (e1 e2) + (< (or (caddr e1) 0) + (or (caddr e2) 0)))) + do (cond + ;; First part. + ((or (not (setq elem (assq attribute cparams))) + (and (numberp part) + (zerop part))) + (push (list attribute value encoded) cparams)) + ;; Repetition of a part; do nothing. + ((and elem + (null number)) + ) + ;; Concatenate continuation parts. + (t + (setcar (cdr elem) (concat (cadr elem) value))))) + ;; Finally decode encoded values. + (cons type (mapcar + (lambda (elem) + (cons (car elem) + (if (nth 2 elem) + (rfc2231-decode-encoded-string (nth 1 elem)) + (nth 1 elem)))) + (nreverse cparams)))))))) + +(defun rfc2231-decode-encoded-string (string) + "Decode an RFC2231-encoded string. +These look like: + \"us-ascii\\='en-us\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\", + \"us-ascii\\='\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\", + \"\\='en-us\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\", + \"\\='\\='This%20is%20%2A%2A%2Afun%2A%2A%2A\", or + \"This is ***fun***\"." + (string-match "\\`\\(?:\\([^']+\\)?'\\([^']+\\)?'\\)?\\(.+\\)" string) + (let ((coding-system (mm-charset-to-coding-system + (match-string 1 string) nil t)) + ;;(language (match-string 2 string)) + (value (match-string 3 string))) + (mm-with-unibyte-buffer + (insert value) + (goto-char (point-min)) + (while (re-search-forward "%\\([0-9A-Fa-f][0-9A-Fa-f]\\)" nil t) + (insert + (prog1 + (string-to-number (match-string 1) 16) + (delete-region (match-beginning 0) (match-end 0))))) + ;; Decode using the charset, if any. + (if (memq coding-system '(nil ascii)) + (buffer-string) + (decode-coding-string (buffer-string) coding-system))))) + +(defun rfc2231-encode-string (param value) + "Return and PARAM=VALUE string encoded according to RFC2231. +Use `mml-insert-parameter' or `mml-insert-parameter-string' to insert +the result of this function." + (let ((control (ietf-drums-token-to-list ietf-drums-no-ws-ctl-token)) + (tspecial (ietf-drums-token-to-list ietf-drums-tspecials)) + (special (ietf-drums-token-to-list "*'%\n\t")) + (ascii (ietf-drums-token-to-list ietf-drums-text-token)) + (num -1) + ;; Don't make lines exceeding 76 column. + (limit (- 74 (length param))) + spacep encodep charsetp charset broken) + (mm-with-multibyte-buffer + (insert value) + (goto-char (point-min)) + (while (not (eobp)) + (cond + ((or (memq (following-char) control) + (memq (following-char) tspecial) + (memq (following-char) special)) + (setq encodep t)) + ((eq (following-char) ? ) + (setq spacep t)) + ((not (memq (following-char) ascii)) + (setq charsetp t))) + (forward-char 1)) + (when charsetp + (setq charset (mm-encode-body))) + (mm-disable-multibyte) + (cond + ((or encodep charsetp + (progn + (end-of-line) + (> (current-column) (if spacep (- limit 2) limit)))) + (setq limit (- limit 6)) + (goto-char (point-min)) + (insert (symbol-name (or charset 'us-ascii)) "''") + (while (not (eobp)) + (if (or (not (memq (following-char) ascii)) + (memq (following-char) control) + (memq (following-char) tspecial) + (memq (following-char) special) + (eq (following-char) ? )) + (progn + (when (>= (current-column) (1- limit)) + (insert ";\n") + (setq broken t)) + (insert "%" (format "%02x" (following-char))) + (delete-char 1)) + (when (> (current-column) limit) + (insert ";\n") + (setq broken t)) + (forward-char 1))) + (goto-char (point-min)) + (if (not broken) + (insert param "*=") + (while (not (eobp)) + (insert (if (>= num 0) " " "") + param "*" (format "%d" (incf num)) "*=") + (forward-line 1)))) + (spacep + (goto-char (point-min)) + (insert param "=\"") + (goto-char (point-max)) + (insert "\"")) + (t + (goto-char (point-min)) + (insert param "="))) + (buffer-string)))) + +(provide 'rfc2231) + +;;; rfc2231.el ends here diff --cc lisp/mail/yenc.el index a4ebd0db15b,00000000000..c8e2d2c7bcd mode 100644,000000..100644 --- a/lisp/mail/yenc.el +++ b/lisp/mail/yenc.el @@@ -1,139 -1,0 +1,139 @@@ +;;; yenc.el --- elisp native yenc decoder + - ;; Copyright (C) 2002-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2002-2017 Free Software Foundation, Inc. + +;; Author: Jesper Harder +;; Keywords: yenc news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Functions for decoding yenc encoded messages. +;; +;; Limitations: +;; +;; * Does not handle multipart messages. +;; * No support for external decoders. +;; * Doesn't check the crc32 checksum (if present). + +;;; Code: + +(eval-when-compile (require 'cl)) + +(defconst yenc-begin-line + "^=ybegin.*$") + +(defconst yenc-decoding-vector + [214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 + 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 + 248 249 250 251 252 253 254 255 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 + 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 + 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 + 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 + 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 + 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 + 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 + 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 + 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 + 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 + 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 + 208 209 210 211 212 213]) + +(defun yenc-first-part-p () + "Say whether the buffer contains the first part of a yEnc file." + (save-excursion + (goto-char (point-min)) + (re-search-forward "^=ybegin part=1 " nil t))) + +(defun yenc-last-part-p () + "Say whether the buffer contains the last part of a yEnc file." + (save-excursion + (goto-char (point-min)) + (let (total-size end-size) + (when (re-search-forward "^=ybegin.*size=\\([0-9]+\\)" nil t) + (setq total-size (match-string 1))) + (when (re-search-forward "^=ypart.*end=\\([0-9]+\\)" nil t) + (setq end-size (match-string 1))) + (and total-size + end-size + (string= total-size end-size))))) + +;;;###autoload +(defun yenc-decode-region (start end) + "Yenc decode region between START and END using an internal decoder." + (interactive "r") + (let (work-buffer) + (unwind-protect + (save-excursion + (goto-char start) + (when (re-search-forward yenc-begin-line end t) + (let ((first (match-end 0)) + (header-alist (yenc-parse-line (match-string 0))) + bytes last footer-alist char) + (when (re-search-forward "^=ypart.*$" end t) + (setq first (match-end 0))) + (when (re-search-forward "^=yend.*$" end t) + (setq last (match-beginning 0)) + (setq footer-alist (yenc-parse-line (match-string 0))) + (setq work-buffer (generate-new-buffer " *yenc-work*")) + (with-current-buffer work-buffer + (set-buffer-multibyte nil)) + (while (< first last) + (setq char (char-after first)) + (cond ((or (eq char ?\r) + (eq char ?\n))) + ((eq char ?=) + (setq char (char-after (incf first))) + (with-current-buffer work-buffer + (insert-char (mod (- char 106) 256) 1))) + (t + (with-current-buffer work-buffer + ;;(insert-char (mod (- char 42) 256) 1) + (insert-char (aref yenc-decoding-vector char) 1)))) + (incf first)) + (setq bytes (buffer-size work-buffer)) + (unless (and (= (cdr (assq 'size header-alist)) bytes) + (= (cdr (assq 'size footer-alist)) bytes)) + (message "Warning: Size mismatch while decoding.")) + (goto-char start) + (delete-region start end) + (insert-buffer-substring work-buffer)))) + (and work-buffer (kill-buffer work-buffer)))))) + +;;;###autoload +(defun yenc-extract-filename () + "Extract file name from an yenc header." + (save-excursion + (when (re-search-forward yenc-begin-line nil t) + (cdr (assoc 'name (yenc-parse-line (match-string 0))))))) + +(defun yenc-parse-line (str) + "Extract file name and size from STR." + (let (result name) + (when (string-match "^=y.*size=\\([0-9]+\\)" str) + (push (cons 'size (string-to-number (match-string 1 str))) result)) + (when (string-match "^=y.*name=\\(.*\\)$" str) + (setq name (match-string 1 str)) + ;; Remove trailing white space + (when (string-match " +$" name) + (setq name (substring name 0 (match-beginning 0)))) + (push (cons 'name name) result)) + result)) + +(provide 'yenc) + +;;; yenc.el ends here diff --cc lisp/man.el index a140e03d74a,181a870ca6b..4f6e1187e0d --- a/lisp/man.el +++ b/lisp/man.el @@@ -1,6 -1,6 +1,6 @@@ -;;; man.el --- browse UNIX manual pages +;;; man.el --- browse UNIX manual pages -*- lexical-binding: t -*- - ;; Copyright (C) 1993-1994, 1996-1997, 2001-2016 Free Software + ;; Copyright (C) 1993-1994, 1996-1997, 2001-2017 Free Software ;; Foundation, Inc. ;; Author: Barry A. Warsaw diff --cc lisp/net/dbus.el index 2d7cd2fc612,7a90f8c24c7..d740829f99c --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@@ -1,6 -1,6 +1,6 @@@ -;;; dbus.el --- Elisp bindings for D-Bus. +;;; dbus.el --- Elisp bindings for D-Bus. -*- lexical-binding: t -*- - ;; Copyright (C) 2007-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2007-2017 Free Software Foundation, Inc. ;; Author: Michael Albinus ;; Keywords: comm, hardware diff --cc lisp/net/html2text.el index 2b1c2057bb4,00000000000..87c71dc504a mode 100644,000000..100644 --- a/lisp/net/html2text.el +++ b/lisp/net/html2text.el @@@ -1,461 -1,0 +1,461 @@@ +;;; html2text.el --- a simple html to plain text converter -*- coding: utf-8 -*- + - ;; Copyright (C) 2002-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2002-2017 Free Software Foundation, Inc. + +;; Author: Joakim Hove + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; These functions provide a simple way to wash/clean html infected +;; mails. Definitely do not work in all cases, but some improvement +;; in readability is generally obtained. Formatting is only done in +;; the buffer, so the next time you enter the article it will be +;; "re-htmlized". +;; +;; The main function is `html2text'. + +;;; Code: + +;; +;; +;; + +(eval-when-compile + (require 'cl)) + +(defvar html2text-format-single-element-list '(("hr" . html2text-clean-hr))) + +(defvar html2text-replace-list + '(("´" . "`") + ("&" . "&") + ("'" . "'") + ("¦" . "|") + ("¢" . "c") + ("ˆ" . "^") + ("©" . "(C)") + ("¤" . "(#)") + ("°" . "degree") + ("÷" . "/") + ("€" . "e") + ("½" . "1/2") + (">" . ">") + ("¿" . "?") + ("«" . "<<") + ("&ldquo" . "\"") + ("‹" . "(") + ("‘" . "`") + ("<" . "<") + ("—" . "--") + (" " . " ") + ("–" . "-") + ("‰" . "%%") + ("±" . "+-") + ("£" . "£") + (""" . "\"") + ("»" . ">>") + ("&rdquo" . "\"") + ("®" . "(R)") + ("›" . ")") + ("’" . "'") + ("§" . "§") + ("¹" . "^1") + ("²" . "^2") + ("³" . "^3") + ("˜" . "~")) + "The map of entity to text. + +This is an alist were each element is a dotted pair consisting of an +old string, and a replacement string. This replacement is done by the +function `html2text-substitute' which basically performs a +`replace-string' operation for every element in the list. This is +completely verbatim - without any use of REGEXP.") + +(defvar html2text-remove-tag-list + '("html" "body" "p" "img" "dir" "head" "div" "br" "font" "title" "meta") + "A list of removable tags. + +This is a list of tags which should be removed, without any +formatting. Note that tags in the list are presented *without* +any \"<\" or \">\". All occurrences of a tag appearing in this +list are removed, irrespective of whether it is a closing or +opening tag, or if the tag has additional attributes. The +deletion is done by the function `html2text-remove-tags'. + +For instance the text: + +\"Here comes something big .\" + +will be reduced to: + +\"Here comes something big.\" + +If this list contains the element \"font\".") + +(defvar html2text-format-tag-list + '(("b" . html2text-clean-bold) + ("strong" . html2text-clean-bold) + ("u" . html2text-clean-underline) + ("i" . html2text-clean-italic) + ("em" . html2text-clean-italic) + ("blockquote" . html2text-clean-blockquote) + ("a" . html2text-clean-anchor) + ("ul" . html2text-clean-ul) + ("ol" . html2text-clean-ol) + ("dl" . html2text-clean-dl) + ("center" . html2text-clean-center)) + "An alist of tags and processing functions. + +This is an alist where each dotted pair consists of a tag, and then +the name of a function to be called when this tag is found. The +function is called with the arguments p1, p2, p3 and p4. These are +demonstrated below: + +\" This is bold text \" + ^ ^ ^ ^ + | | | | +p1 p2 p3 p4 + +Then the called function will typically format the text somewhat and +remove the tags.") + +(defvar html2text-remove-tag-list2 '("li" "dt" "dd" "meta") + "Another list of removable tags. + +This is a list of tags which are removed similarly to the list +`html2text-remove-tag-list' - but these tags are retained for the +formatting, and then moved afterward.") + +;; +;; +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; +;; +;; + + +(defun html2text-replace-string (from-string to-string min max) + "Replace FROM-STRING with TO-STRING in region from MIN to MAX." + (goto-char min) + (let ((delta (- (string-width to-string) (string-width from-string))) + (change 0)) + (while (search-forward from-string max t) + (replace-match to-string) + (setq change (+ change delta))) + change)) + +;; +;; +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; +;; i.e. +;; + +(defun html2text-attr-value (list attribute) + "Get value of ATTRIBUTE from LIST." + (nth 1 (assoc attribute list))) + +(defun html2text-get-attr (p1 p2) + (goto-char p1) + (re-search-forward "\\s-+" p2 t) + (let (attr-list) + (while (re-search-forward "[-a-z0-9._]+" p2 t) + (setq attr-list + (cons + (list (match-string 0) + (when (looking-at "\\s-*=") + (goto-char (match-end 0)) + (skip-chars-forward "[:space:]") + (when (or (looking-at "\"[^\"]*\"\\|'[^']*'") + (looking-at "[-a-z0-9._:]+")) + (goto-char (match-end 0)) + (match-string 0)))) + attr-list))) + attr-list)) + +;; +;; +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; +;; +;; +(defun html2text-clean-list-items (p1 p2 list-type) + (goto-char p1) + (let ((item-nr 0) + (items 0)) + (while (search-forward "
  • " p2 t) + (setq items (1+ items))) + (goto-char p1) + (while (< item-nr items) + (setq item-nr (1+ item-nr)) + (search-forward "
  • " (point-max) t) + (cond + ((string= list-type "ul") (insert " o ")) + ((string= list-type "ol") (insert (format " %s: " item-nr))) + (t (insert " x ")))))) + +(defun html2text-clean-dtdd (p1 p2) + (goto-char p1) + (let ((items 0) + (item-nr 0)) + (while (search-forward "
    " p2 t) + (setq items (1+ items))) + (goto-char p1) + (while (< item-nr items) + (setq item-nr (1+ item-nr)) + (re-search-forward "
    \\([ ]*\\)" (point-max) t) + (when (match-string 1) + (delete-region (point) (- (point) (string-width (match-string 1))))) + (let ((def-p1 (point)) + (def-p2 0)) + (re-search-forward "\\([ ]*\\)\\(
    \\|
    \\)" (point-max) t) + (if (match-string 1) + (progn + (let* ((mw1 (string-width (match-string 1))) + (mw2 (string-width (match-string 2))) + (mw (+ mw1 mw2))) + (goto-char (- (point) mw)) + (delete-region (point) (+ (point) mw1)) + (setq def-p2 (point)))) + (setq def-p2 (- (point) (string-width (match-string 2))))) + (put-text-property def-p1 def-p2 'face 'bold))))) + +(defun html2text-delete-tags (p1 p2 p3 p4) + (delete-region p1 p2) + (delete-region (- p3 (- p2 p1)) (- p4 (- p2 p1)))) + +(defun html2text-delete-single-tag (p1 p2) + (delete-region p1 p2)) + +(defun html2text-clean-hr (p1 p2) + (html2text-delete-single-tag p1 p2) + (goto-char p1) + (newline 1) + (insert (make-string fill-column ?-))) + +(defun html2text-clean-ul (p1 p2 p3 p4) + (html2text-delete-tags p1 p2 p3 p4) + (html2text-clean-list-items p1 (- p3 (- p1 p2)) "ul")) + +(defun html2text-clean-ol (p1 p2 p3 p4) + (html2text-delete-tags p1 p2 p3 p4) + (html2text-clean-list-items p1 (- p3 (- p1 p2)) "ol")) + +(defun html2text-clean-dl (p1 p2 p3 p4) + (html2text-delete-tags p1 p2 p3 p4) + (html2text-clean-dtdd p1 (- p3 (- p1 p2)))) + +(defun html2text-clean-center (p1 p2 p3 p4) + (html2text-delete-tags p1 p2 p3 p4) + (center-region p1 (- p3 (- p2 p1)))) + +(defun html2text-clean-bold (p1 p2 p3 p4) + (put-text-property p2 p3 'face 'bold) + (html2text-delete-tags p1 p2 p3 p4)) + +(defun html2text-clean-title (p1 p2 p3 p4) + (put-text-property p2 p3 'face 'bold) + (html2text-delete-tags p1 p2 p3 p4)) + +(defun html2text-clean-underline (p1 p2 p3 p4) + (put-text-property p2 p3 'face 'underline) + (html2text-delete-tags p1 p2 p3 p4)) + +(defun html2text-clean-italic (p1 p2 p3 p4) + (put-text-property p2 p3 'face 'italic) + (html2text-delete-tags p1 p2 p3 p4)) + +(defun html2text-clean-font (p1 p2 p3 p4) + (html2text-delete-tags p1 p2 p3 p4)) + +(defun html2text-clean-blockquote (p1 p2 p3 p4) + (html2text-delete-tags p1 p2 p3 p4)) + +(defun html2text-clean-anchor (p1 p2 p3 p4) + ;; If someone can explain how to make the URL clickable I will surely + ;; improve upon this. + ;; Maybe `goto-addr.el' can be used here. + (let* ((attr-list (html2text-get-attr p1 p2)) + (href (html2text-attr-value attr-list "href"))) + (delete-region p1 p4) + (when href + (goto-char p1) + (insert (if (string-match "\\`['\"].*['\"]\\'" href) + (substring href 1 -1) href)) + (put-text-property p1 (point) 'face 'bold)))) + +;; +;; +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; +;; +;; + +(defun html2text-fix-paragraph (p1 p2) + (goto-char p1) + (let ((refill-start) + (refill-stop)) + (when (re-search-forward "
    $" p2 t) + (goto-char p1) + (when (re-search-forward ".+[^<][^b][^r][^>]$" p2 t) + (beginning-of-line) + (setq refill-start (point)) + (goto-char p2) + (re-search-backward ".+[^<][^b][^r][^>]$" refill-start t) + (forward-line 1) + (end-of-line) + ;; refill-stop should ideally be adjusted to + ;; accommodate the "
    " strings which are removed + ;; between refill-start and refill-stop. Can simply + ;; be returned from my-replace-string + (setq refill-stop (+ (point) + (html2text-replace-string + "
    " "" + refill-start (point)))) + ;; (message "Point = %s refill-stop = %s" (point) refill-stop) + ;; (sleep-for 4) + (fill-region refill-start refill-stop)))) + (html2text-replace-string "
    " "" p1 p2)) + +;; +;; This one is interactive ... +;; +(defun html2text-fix-paragraphs () + "This _tries_ to fix up the paragraphs - this is done in quite a ad-hook +fashion, quite close to pure guess-work. It does work in some cases though." + (interactive) + (goto-char (point-min)) + (while (re-search-forward "^
    $" nil t) + (delete-region (match-beginning 0) (match-end 0))) + ;; Removing lonely
    on a single line, if they are left intact we + ;; don't have any paragraphs at all. + (goto-char (point-min)) + (while (not (eobp)) + (let ((p1 (point))) + (forward-paragraph 1) + ;;(message "Kaller fix med p1=%s p2=%s " p1 (1- (point))) (sleep-for 5) + (html2text-fix-paragraph p1 (1- (point))) + (goto-char p1) + (when (not (eobp)) + (forward-paragraph 1))))) + +;; +;;     +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; +;; +;; + +(defun html2text-remove-tags (tag-list) + "Removes the tags listed in the list `html2text-remove-tag-list'. +See the documentation for that variable." + (interactive) + (dolist (tag tag-list) + (goto-char (point-min)) + (while (re-search-forward (format "\\(]*>\\)" tag) (point-max) t) + (delete-region (match-beginning 0) (match-end 0))))) + +(defun html2text-format-tags () + "See the variable `html2text-format-tag-list' for documentation." + (interactive) + (dolist (tag-and-function html2text-format-tag-list) + (let ((tag (car tag-and-function)) + (function (cdr tag-and-function))) + (goto-char (point-min)) + (while (re-search-forward (format "\\(<%s\\( [^>]*\\)?>\\)" tag) + (point-max) t) + (let ((p1) + (p2 (point)) + (p3) (p4)) + (search-backward "<" (point-min) t) + (setq p1 (point)) + (unless (search-forward (format "" tag) (point-max) t) + (goto-char p2) + (insert (format "" tag))) + (setq p4 (point)) + (search-backward "]*\\)?>\\)" tag) + (point-max) t) + (let ((p1) + (p2 (point))) + (search-backward "<" (point-min) t) + (setq p1 (point)) + (funcall function p1 p2)))))) + +;; +;; Main function +;; + +;;;###autoload +(defun html2text () + "Convert HTML to plain text in the current buffer." + (interactive) + (save-excursion + (let ((case-fold-search t) + (buffer-read-only)) + (html2text-remove-tags html2text-remove-tag-list) + (html2text-format-tags) + (html2text-remove-tags html2text-remove-tag-list2) + (html2text-substitute) + (html2text-format-single-elements) + (html2text-fix-paragraphs)))) + +;; +;; +;; +(provide 'html2text) + +;;; html2text.el ends here diff --cc lisp/net/mailcap.el index f71d7ba6675,00000000000..4e53b5a2861 mode 100644,000000..100644 --- a/lisp/net/mailcap.el +++ b/lisp/net/mailcap.el @@@ -1,1111 -1,0 +1,1111 @@@ +;;; mailcap.el --- MIME media types configuration + - ;; Copyright (C) 1998-2016 Free Software Foundation, Inc. ++;; Copyright (C) 1998-2017 Free Software Foundation, Inc. + +;; Author: William M. Perry +;; Lars Magne Ingebrigtsen +;; Keywords: news, mail, multimedia + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Provides configuration of MIME media types from directly from Lisp +;; and via the usual mailcap mechanism (RFC 1524). Deals with +;; mime.types similarly. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(autoload 'mail-header-parse-content-type "mail-parse") + +(defgroup mailcap nil + "Definition of viewers for MIME types." + :version "21.1" + :group 'mime) + +(defvar mailcap-parse-args-syntax-table + (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) + (modify-syntax-entry ?' "\"" table) + (modify-syntax-entry ?` "\"" table) + (modify-syntax-entry ?{ "(" table) + (modify-syntax-entry ?} ")" table) + table) + "A syntax table for parsing SGML attributes.") + +(defvar mailcap-print-command + (mapconcat 'identity + (cons (if (boundp 'lpr-command) + lpr-command + "lpr") + (when (boundp 'lpr-switches) + (if (stringp lpr-switches) + (list lpr-switches) + lpr-switches))) + " ") + "Shell command (including switches) used to print PostScript files.") + +(defun mailcap--get-user-mime-data (sym) + (let ((val (default-value sym)) + res) + (dolist (entry val) + (push (list (cdr (assq 'viewer entry)) + (cdr (assq 'type entry)) + (cdr (assq 'test entry))) + res)) + (nreverse res))) + +(defun mailcap--set-user-mime-data (sym val) + (let (res) + (dolist (entry val) + (push `((viewer . ,(car entry)) + (type . ,(cadr entry)) + ,@(when (cl-caddr entry) + `((test . ,(cl-caddr entry))))) + res)) + (set-default sym (nreverse res)))) + +(defcustom mailcap-user-mime-data nil + "A list of viewers preferred for different MIME types. +The elements of the list are alists of the following structure + + ((viewer . VIEWER) + (type . MIME-TYPE) + (test . TEST)) + +where VIEWER is either a lisp command, e.g., a major-mode, or a +string containing a shell command for viewing files of the +defined MIME-TYPE. In case of a shell command, %s will be +replaced with the file. + +MIME-TYPE is a regular expression being matched against the +actual MIME type. It is implicitly surrounded with ^ and $. + +TEST is an lisp form which is evaluated in order to test if the +entry should be chosen. The `test' entry is optional. + +When selecting a viewer for a given MIME type, the first viewer +in this list with a matching MIME-TYPE and successful TEST is +selected. Only if none matches, the standard `mailcap-mime-data' +is consulted." + :type '(repeat + (list + (choice (function :tag "Function or mode") + (string :tag "Shell command")) + (regexp :tag "MIME Type") + (sexp :tag "Test (optional)"))) + :get #'mailcap--get-user-mime-data + :set #'mailcap--set-user-mime-data + :group 'mailcap) + +;; Postpone using defcustom for this as it's so big and we essentially +;; have to have two copies of the data around then. Perhaps just +;; customize the Lisp viewers and rely on the normal configuration +;; files for the rest? -- fx +(defvar mailcap-mime-data + `(("application" + ("vnd\\.ms-excel" + (viewer . "gnumeric %s") + (test . (getenv "DISPLAY")) + (type . "application/vnd.ms-excel")) + ("x-x509-ca-cert" + (viewer . ssl-view-site-cert) + (type . "application/x-x509-ca-cert")) + ("x-x509-user-cert" + (viewer . ssl-view-user-cert) + (type . "application/x-x509-user-cert")) + ("octet-stream" + (viewer . mailcap-save-binary-file) + (non-viewer . t) + (type . "application/octet-stream")) + ("dvi" + (viewer . "xdvi -safer %s") + (test . (eq window-system 'x)) + ("needsx11") + (type . "application/dvi") + ("print" . "dvips -qRP %s")) + ("dvi" + (viewer . "dvitty %s") + (test . (not (getenv "DISPLAY"))) + (type . "application/dvi") + ("print" . "dvips -qRP %s")) + ("emacs-lisp" + (viewer . mailcap-maybe-eval) + (type . "application/emacs-lisp")) + ("x-emacs-lisp" + (viewer . mailcap-maybe-eval) + (type . "application/x-emacs-lisp")) + ("x-tar" + (viewer . mailcap-save-binary-file) + (non-viewer . t) + (type . "application/x-tar")) + ("x-latex" + (viewer . tex-mode) + (type . "application/x-latex")) + ("x-tex" + (viewer . tex-mode) + (type . "application/x-tex")) + ("latex" + (viewer . tex-mode) + (type . "application/latex")) + ("tex" + (viewer . tex-mode) + (type . "application/tex")) + ("texinfo" + (viewer . texinfo-mode) + (type . "application/tex")) + ("zip" + (viewer . mailcap-save-binary-file) + (non-viewer . t) + (type . "application/zip") + ("copiousoutput")) + ("pdf" + (viewer . pdf-view-mode) + (type . "application/pdf") + (test . (eq window-system 'x))) + ("pdf" + (viewer . doc-view-mode) + (type . "application/pdf") + (test . (eq window-system 'x))) + ("pdf" + (viewer . "gv -safer %s") + (type . "application/pdf") + (test . window-system) + ("print" . ,(concat "pdf2ps %s - | " mailcap-print-command))) + ("pdf" + (viewer . "gpdf %s") + (type . "application/pdf") + ("print" . ,(concat "pdftops %s - | " mailcap-print-command)) + (test . (eq window-system 'x))) + ("pdf" + (viewer . "xpdf %s") + (type . "application/pdf") + ("print" . ,(concat "pdftops %s - | " mailcap-print-command)) + (test . (eq window-system 'x))) + ("pdf" + (viewer . ,(concat "pdftotext %s -")) + (type . "application/pdf") + ("print" . ,(concat "pdftops %s - | " mailcap-print-command)) + ("copiousoutput")) + ("postscript" + (viewer . "gv -safer %s") + (type . "application/postscript") + (test . window-system) + ("print" . ,(concat mailcap-print-command " %s")) + ("needsx11")) + ("postscript" + (viewer . "ghostview -dSAFER %s") + (type . "application/postscript") + (test . (eq window-system 'x)) + ("print" . ,(concat mailcap-print-command " %s")) + ("needsx11")) + ("postscript" + (viewer . "ps2ascii %s") + (type . "application/postscript") + (test . (not (getenv "DISPLAY"))) + ("print" . ,(concat mailcap-print-command " %s")) + ("copiousoutput")) + ("sieve" + (viewer . sieve-mode) + (type . "application/sieve")) + ("pgp-keys" + (viewer . "gpg --import --interactive --verbose") + (type . "application/pgp-keys") + ("needsterminal"))) + ("audio" + ("x-mpeg" + (viewer . "maplay %s") + (type . "audio/x-mpeg")) + (".*" + (viewer . "showaudio") + (type . "audio/*"))) + ("message" + ("rfc-*822" + (viewer . mm-view-message) + (test . (and (featurep 'gnus) + (gnus-alive-p))) + (type . "message/rfc822")) + ("rfc-*822" + (viewer . vm-mode) + (type . "message/rfc822")) + ("rfc-*822" + (viewer . view-mode) + (type . "message/rfc822"))) + ("image" + ("x-xwd" + (viewer . "xwud -in %s") + (type . "image/x-xwd") + ("compose" . "xwd -frame > %s") + (test . (eq window-system 'x)) + ("needsx11")) + ("x11-dump" + (viewer . "xwud -in %s") + (type . "image/x-xwd") + ("compose" . "xwd -frame > %s") + (test . (eq window-system 'x)) + ("needsx11")) + ("windowdump" + (viewer . "xwud -in %s") + (type . "image/x-xwd") + ("compose" . "xwd -frame > %s") + (test . (eq window-system 'x)) + ("needsx11")) + (".*" + (viewer . "display %s") + (type . "image/*") + (test . (eq window-system 'x)) + ("needsx11")) + (".*" + (viewer . "ee %s") + (type . "image/*") + (test . (eq window-system 'x)) + ("needsx11"))) + ("text" + ("plain" + (viewer . view-mode) + (type . "text/plain")) + ("plain" + (viewer . fundamental-mode) + (type . "text/plain")) + ("enriched" + (viewer . enriched-decode) + (type . "text/enriched")) + ("dns" + (viewer . dns-mode) + (type . "text/dns"))) + ("video" + ("mpeg" + (viewer . "mpeg_play %s") + (type . "video/mpeg") + (test . (eq window-system 'x)) + ("needsx11"))) + ("x-world" + ("x-vrml" + (viewer . "webspace -remote %s -URL %u") + (type . "x-world/x-vrml") + ("description" + "VRML document"))) + ("archive" + ("tar" + (viewer . tar-mode) + (type . "archive/tar")))) + "The mailcap structure is an assoc list of assoc lists. +1st assoc list is keyed on the major content-type +2nd assoc list is keyed on the minor content-type (which can be a regexp) + +Which looks like: +----------------- + ((\"application\" + (\"postscript\" . )) + (\"text\" + (\"plain\" . ))) + +Where is another assoc list of the various information +related to the mailcap RFC 1524. This is keyed on the lowercase +attribute name (viewer, test, etc). This looks like: + ((viewer . VIEWERINFO) + (test . TESTINFO) + (xxxx . \"STRING\") + FLAG) + +Where VIEWERINFO specifies how the content-type is viewed. Can be +a string, in which case it is run through a shell, with appropriate +parameters, or a symbol, in which case the symbol is `funcall'ed if +and only if it exists as a function, with the buffer as an argument. + +TESTINFO is a test for the viewer's applicability, or nil. If nil, it +means the viewer is always valid. If it is a Lisp function, it is +called with a list of items from any extra fields from the +Content-Type header as argument to return a boolean value for the +validity. Otherwise, if it is a non-function Lisp symbol or list +whose car is a symbol, it is `eval'led to yield the validity. If it +is a string or list of strings, it represents a shell command to run +to return a true or false shell value for the validity.") +(put 'mailcap-mime-data 'risky-local-variable t) + +(defcustom mailcap-download-directory nil + "Directory to which `mailcap-save-binary-file' downloads files by default. +nil means your home directory." + :type '(choice (const :tag "Home directory" nil) + directory) + :group 'mailcap) + +(defvar mailcap-poor-system-types + '(ms-dos windows-nt) + "Systems that don't have a Unix-like directory hierarchy.") + +;;; +;;; Utility functions +;;; + +(defun mailcap-save-binary-file () + (goto-char (point-min)) + (unwind-protect + (let ((file (read-file-name + "Filename to save as: " + (or mailcap-download-directory "~/"))) + (require-final-newline nil)) + (write-region (point-min) (point-max) file)) + (kill-buffer (current-buffer)))) + +(defvar mailcap-maybe-eval-warning + "*** WARNING *** + +This MIME part contains untrusted and possibly harmful content. +If you evaluate the Emacs Lisp code contained in it, a lot of nasty +things can happen. Please examine the code very carefully before you +instruct Emacs to evaluate it. You can browse the buffer containing +the code using \\[scroll-other-window]. + +If you are unsure what to do, please answer \"no\"." + "Text of warning message displayed by `mailcap-maybe-eval'. +Make sure that this text consists only of few text lines. Otherwise, +Gnus might fail to display all of it.") + +(defun mailcap-maybe-eval () + "Maybe evaluate a buffer of Emacs Lisp code." + (let ((lisp-buffer (current-buffer))) + (goto-char (point-min)) + (when + (save-window-excursion + (delete-other-windows) + (let ((buffer (get-buffer-create (generate-new-buffer-name + "*Warning*")))) + (unwind-protect + (with-current-buffer buffer + (insert (substitute-command-keys + mailcap-maybe-eval-warning)) + (goto-char (point-min)) + (display-buffer buffer) + (yes-or-no-p "This is potentially dangerous emacs-lisp code, evaluate it? ")) + (kill-buffer buffer)))) + (eval-buffer (current-buffer))) + (when (buffer-live-p lisp-buffer) + (with-current-buffer lisp-buffer + (emacs-lisp-mode))))) + + +;;; +;;; The mailcap parser +;;; + +(defun mailcap-replace-regexp (regexp to-string) + ;; Quiet replace-regexp. + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (replace-match to-string t nil))) + +(defvar mailcap-parsed-p nil) + +(defun mailcap-parse-mailcaps (&optional path force) + "Parse out all the mailcaps specified in a path string PATH. +Components of PATH are separated by the `path-separator' character +appropriate for this system. If FORCE, re-parse even if already +parsed. If PATH is omitted, use the value of environment variable +MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus +/usr/local/etc/mailcap." + (interactive (list nil t)) + (when (or (not mailcap-parsed-p) + force) + (cond + (path nil) + ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS"))) + ((memq system-type mailcap-poor-system-types) + (setq path '("~/.mailcap" "~/mail.cap" "~/etc/mail.cap"))) + (t (setq path + ;; This is per RFC 1524, specifically + ;; with /usr before /usr/local. + '("~/.mailcap" "/etc/mailcap" "/usr/etc/mailcap" + "/usr/local/etc/mailcap")))) + (dolist (fname (reverse + (if (stringp path) + (split-string path path-separator t) + path))) + (if (and (file-readable-p fname) + (file-regular-p fname)) + (mailcap-parse-mailcap fname))) + (setq mailcap-parsed-p t))) + +(defun mailcap-parse-mailcap (fname) + "Parse out the mailcap file specified by FNAME." + (let (major ; The major mime type (image/audio/etc) + minor ; The minor mime type (gif, basic, etc) + save-pos ; Misc saved positions used in parsing + viewer ; How to view this mime type + info ; Misc info about this mime type + ) + (with-temp-buffer + (insert-file-contents fname) + (set-syntax-table mailcap-parse-args-syntax-table) + (mailcap-replace-regexp "#.*" "") ; Remove all comments + (mailcap-replace-regexp "\\\\[ \t]*\n" " ") ; And collapse spaces + (mailcap-replace-regexp "\n+" "\n") ; And blank lines + (goto-char (point-max)) + (skip-chars-backward " \t\n") + (delete-region (point) (point-max)) + (while (not (bobp)) + (skip-chars-backward " \t\n") + (beginning-of-line) + (setq save-pos (point) + info nil) + (skip-chars-forward "^/; \t\n") + (downcase-region save-pos (point)) + (setq major (buffer-substring save-pos (point))) + (skip-chars-forward " \t") + (setq minor "") + (when (eq (char-after) ?/) + (forward-char) + (skip-chars-forward " \t") + (setq save-pos (point)) + (skip-chars-forward "^; \t\n") + (downcase-region save-pos (point)) + (setq minor + (cond + ((eq ?* (or (char-after save-pos) 0)) ".*") + ((= (point) save-pos) ".*") + (t (regexp-quote (buffer-substring save-pos (point))))))) + (skip-chars-forward " \t") + ;;; Got the major/minor chunks, now for the viewers/etc + ;;; The first item _must_ be a viewer, according to the + ;;; RFC for mailcap files (#1524) + (setq viewer "") + (when (eq (char-after) ?\;) + (forward-char) + (skip-chars-forward " \t") + (setq save-pos (point)) + (skip-chars-forward "^;\n") + ;; skip \; + (while (eq (char-before) ?\\) + (backward-delete-char 1) + (forward-char) + (skip-chars-forward "^;\n")) + (if (eq (or (char-after save-pos) 0) ?') + (setq viewer (progn + (narrow-to-region (1+ save-pos) (point)) + (goto-char (point-min)) + (prog1 + (read (current-buffer)) + (goto-char (point-max)) + (widen)))) + (setq viewer (buffer-substring save-pos (point))))) + (setq save-pos (point)) + (end-of-line) + (unless (equal viewer "") + (setq info (nconc (list (cons 'viewer viewer) + (cons 'type (concat major "/" + (if (string= minor ".*") + "*" minor)))) + (mailcap-parse-mailcap-extras save-pos (point)))) + (mailcap-mailcap-entry-passes-test info) + (mailcap-add-mailcap-entry major minor info)) + (beginning-of-line))))) + +(defun mailcap-parse-mailcap-extras (st nd) + "Grab all the extra stuff from a mailcap entry." + (let ( + name ; From name= + value ; its value + results ; Assoc list of results + name-pos ; Start of XXXX= position + val-pos ; Start of value position + done ; Found end of \'d ;s? + ) + (save-restriction + (narrow-to-region st nd) + (goto-char (point-min)) + (skip-chars-forward " \n\t;") + (while (not (eobp)) + (setq done nil) + (setq name-pos (point)) + (skip-chars-forward "^ \n\t=;") + (downcase-region name-pos (point)) + (setq name (buffer-substring name-pos (point))) + (skip-chars-forward " \t\n") + (if (not (eq (char-after (point)) ?=)) ; There is no value + (setq value t) + (skip-chars-forward " \t\n=") + (setq val-pos (point)) + (if (memq (char-after val-pos) '(?\" ?')) + (progn + (setq val-pos (1+ val-pos)) + (condition-case nil + (progn + (forward-sexp 1) + (backward-char 1)) + (error (goto-char (point-max))))) + (while (not done) + (skip-chars-forward "^;") + (if (eq (char-after (1- (point))) ?\\ ) + (progn + (subst-char-in-region (1- (point)) (point) ?\\ ? ) + (skip-chars-forward ";")) + (setq done t)))) + (setq value (buffer-substring val-pos (point)))) + ;; `test' as symbol, others like "copiousoutput" and "needsx11" as + ;; strings + (push (cons (if (string-equal name "test") 'test name) value) results) + (skip-chars-forward " \";\n\t")) + results))) + +(defun mailcap-mailcap-entry-passes-test (info) + "Replace the test clause of INFO itself with a boolean for some cases. +This function supports only `test -n $DISPLAY' and `test -z $DISPLAY', +replaces them with t or nil. As for others or if INFO has a interactive +spec (needsterm, needsterminal, or needsx11) but DISPLAY is not set, +the test clause will be unchanged." + (let ((test (assq 'test info)) ; The test clause + status) + (setq status (and test (split-string (cdr test) " "))) + (if (and (or (assoc "needsterm" info) + (assoc "needsterminal" info) + (assoc "needsx11" info)) + (not (getenv "DISPLAY"))) + (setq status nil) + (cond + ((and (equal (nth 0 status) "test") + (equal (nth 1 status) "-n") + (or (equal (nth 2 status) "$DISPLAY") + (equal (nth 2 status) "\"$DISPLAY\""))) + (setq status (if (getenv "DISPLAY") t nil))) + ((and (equal (nth 0 status) "test") + (equal (nth 1 status) "-z") + (or (equal (nth 2 status) "$DISPLAY") + (equal (nth 2 status) "\"$DISPLAY\""))) + (setq status (if (getenv "DISPLAY") nil t))) + (test nil) + (t nil))) + (and test (listp test) (setcdr test status)))) + +;;; +;;; The action routines. +;;; + +(defun mailcap-possible-viewers (major minor) + "Return a list of possible viewers from MAJOR for minor type MINOR." + (let ((exact '()) + (wildcard '())) + (while major + (cond + ((equal (car (car major)) minor) + (push (cdr (car major)) exact)) + ((and minor (string-match (concat "^" (car (car major)) "$") minor)) + (push (cdr (car major)) wildcard))) + (setq major (cdr major))) + (nconc exact wildcard))) + +(defun mailcap-unescape-mime-test (test type-info) + (let (save-pos save-chr subst) + (cond + ((symbolp test) test) + ((and (listp test) (symbolp (car test))) test) + ((or (stringp test) + (and (listp test) (stringp (car test)) + (setq test (mapconcat 'identity test " ")))) + (with-temp-buffer + (insert test) + (goto-char (point-min)) + (while (not (eobp)) + (skip-chars-forward "^%") + (if (/= (- (point) + (progn (skip-chars-backward "\\\\") + (point))) + 0) ; It is an escaped % + (progn + (delete-char 1) + (skip-chars-forward "%.")) + (setq save-pos (point)) + (skip-chars-forward "%") + (setq save-chr (char-after (point))) + ;; Escapes: + ;; %s: name of a file for the body data + ;; %t: content-type + ;; %{ ;; Keywords: network diff --cc lisp/net/newsticker.el index 7eff422e4ea,ecd54967a96..971bdf64f41 --- a/lisp/net/newsticker.el +++ b/lisp/net/newsticker.el @@@ -1,6 -1,6 +1,6 @@@ -;;; newsticker.el --- A Newsticker for Emacs. +;;; newsticker.el --- A Newsticker for Emacs. -*- lexical-binding: t -*- - ;; Copyright (C) 2003-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2003-2017 Free Software Foundation, Inc. ;; Author: Ulf Jasper ;; Filename: newsticker.el diff --cc lisp/net/pop3.el index 3964288fd23,00000000000..6230a15c85b mode 100644,000000..100644 --- a/lisp/net/pop3.el +++ b/lisp/net/pop3.el @@@ -1,915 -1,0 +1,915 @@@ +;;; pop3.el --- Post Office Protocol (RFC 1460) interface + - ;; Copyright (C) 1996-2016 Free Software Foundation, Inc. ++;; Copyright (C) 1996-2017 Free Software Foundation, Inc. + +;; Author: Richard L. Pieri +;; Maintainer: emacs-devel@gnu.org +;; Keywords: mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Most of the standard Post Office Protocol version 3 (RFC 1460) commands +;; are implemented. The LIST command has not been implemented due to lack +;; of actual usefulness. +;; The optional POP3 command TOP has not been implemented. + +;; This program was inspired by Kyle E. Jones's vm-pop program. + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'mail-utils) +(defvar parse-time-months) + +(defgroup pop3 nil + "Post Office Protocol." + :group 'mail + :group 'mail-source) + +(defcustom pop3-maildrop (or (user-login-name) + (getenv "LOGNAME") + (getenv "USER")) + "POP3 maildrop." + :version "22.1" ;; Oort Gnus + :type 'string + :group 'pop3) + +(defcustom pop3-mailhost (or (getenv "MAILHOST") ;; nil -> mismatch + "pop3") + "POP3 mailhost." + :version "22.1" ;; Oort Gnus + :type 'string + :group 'pop3) + +(defcustom pop3-port 110 + "POP3 port." + :version "22.1" ;; Oort Gnus + :type 'number + :group 'pop3) + +(defcustom pop3-password-required t + "Non-nil if a password is required when connecting to POP server." + :version "22.1" ;; Oort Gnus + :type 'boolean + :group 'pop3) + +;; Should this be customizable? +(defcustom pop3-password nil + "Password to use when connecting to POP server." + :type '(choice (const nil) string) + :group 'pop3) + +(defcustom pop3-authentication-scheme 'pass + "POP3 authentication scheme. +Defaults to `pass', for the standard USER/PASS authentication. The other +valid value is `apop'." + :type '(choice (const :tag "Normal user/password" pass) + (const :tag "APOP" apop)) + :version "22.1" ;; Oort Gnus + :group 'pop3) + +(defcustom pop3-stream-length 100 + "How many messages should be requested at one time. +The lower the number, the more latency-sensitive the fetching +will be. If your pop3 server doesn't support streaming at all, +set this to 1." + :type 'number + :version "24.1" + :group 'pop3) + +(defcustom pop3-leave-mail-on-server nil + "Non-nil if the mail is to be left on the POP server after fetching. +Mails once fetched will never be fetched again by the UIDL control. + +If this is neither nil nor a number, all mails will be left on the +server. If this is a number, leave mails on the server for this many +days since you first checked new mails. If this is nil, mails will be +deleted on the server right after fetching. + +Gnus users should use the `:leave' keyword in a mail source to direct +the behavior per server, rather than directly modifying this value. + +Note that POP servers maintain no state information between sessions, +so what the client believes is there and what is actually there may +not match up. If they do not, then you may get duplicate mails or +the whole thing can fall apart and leave you with a corrupt mailbox." + :version "24.4" + :type '(choice (const :tag "Don't leave mails" nil) + (const :tag "Leave all mails" t) + (number :tag "Leave mails for this many days" :value 14)) + :group 'pop3) + +(defcustom pop3-uidl-file "~/.pop3-uidl" + "File used to save UIDL." + :version "24.4" + :type 'file + :group 'pop3) + +(defcustom pop3-uidl-file-backup '(0 9) + "How to backup the UIDL file `pop3-uidl-file' when updating. +If it is a list of numbers, the first one binds `kept-old-versions' and +the other binds `kept-new-versions' to keep number of oldest and newest +versions. Otherwise, the value binds `version-control' (which see). + +Note: Backup will take place whenever you check new mails on a server. +So, you may lose the backup files having been saved before a trouble +if you set it so as to make too few backups whereas you have access to +many servers." + :version "24.4" + :type '(choice (group :tag "Keep versions" :format "\n%v" :indent 3 + (number :tag "oldest") + (number :tag "newest")) + (sexp :format "%v" + :match (lambda (widget value) + (condition-case nil + (not (and (numberp (car value)) + (numberp (car (cdr value))))) + (error t))))) + :group 'pop3) + +(defvar pop3-timestamp nil + "Timestamp returned when initially connected to the POP server. +Used for APOP authentication.") + +(defvar pop3-read-point nil) +(defvar pop3-debug nil) + +;; Borrowed from nnheader-accept-process-output in nnheader.el. See the +;; comments there for explanations about the values. + +(eval-and-compile + (if (and (fboundp 'nnheader-accept-process-output) + (boundp 'nnheader-read-timeout)) + (defalias 'pop3-accept-process-output 'nnheader-accept-process-output) + ;; Borrowed from `nnheader.el': + (defvar pop3-read-timeout + (if (string-match "windows-nt\\|os/2\\|cygwin" + (symbol-name system-type)) + 1.0 + 0.01) + "How long pop3 should wait between checking for the end of output. +Shorter values mean quicker response, but are more CPU intensive.") + (defun pop3-accept-process-output (process) + (accept-process-output + process + (truncate pop3-read-timeout) + (truncate (* (- pop3-read-timeout + (truncate pop3-read-timeout)) + 1000)))))) + +(defvar pop3-uidl) +;; List of UIDLs of existing messages at present in the server: +;; ("UIDL1" "UIDL2" "UIDL3"...) + +(defvar pop3-uidl-saved) +;; Locally saved UIDL data; an alist of the server, the user, and the UIDL +;; and timestamp pairs: +;; (("SERVER_A" ("USER_A1" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...) +;; ("USER_A2" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...) +;; ...) +;; ("SERVER_B" ("USER_B1" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...) +;; ("USER_B2" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...) +;; ...)) +;; Where TIMESTAMP is the most significant two digits of an Emacs time, +;; i.e. the return value of `current-time'. + +;;;###autoload +(defun pop3-movemail (file) + "Transfer contents of a maildrop to the specified FILE. +Use streaming commands." + (let ((process (pop3-open-server pop3-mailhost pop3-port)) + messages total-size + pop3-uidl + pop3-uidl-saved) + (pop3-logon process) + (if pop3-leave-mail-on-server + (setq messages (pop3-uidl-stat process) + total-size (cadr messages) + messages (car messages)) + (let ((size (pop3-stat process))) + (dotimes (i (car size)) (push (1+ i) messages)) + (setq messages (nreverse messages) + total-size (cadr size)))) + (when messages + (with-current-buffer (process-buffer process) + (pop3-send-streaming-command process "RETR" messages total-size) + (pop3-write-to-file file messages) + (unless pop3-leave-mail-on-server + (pop3-send-streaming-command process "DELE" messages nil)))) + (if pop3-leave-mail-on-server + (when (prog1 (pop3-uidl-dele process) (pop3-quit process)) + (pop3-uidl-save)) + (pop3-quit process) + ;; Remove UIDL data for the account that got not to leave mails. + (setq pop3-uidl-saved (pop3-uidl-load)) + (let ((elt (assoc pop3-maildrop + (cdr (assoc pop3-mailhost pop3-uidl-saved))))) + (when elt + (setcdr elt nil) + (pop3-uidl-save)))) + t)) + +(defun pop3-send-streaming-command (process command messages total-size) + (erase-buffer) + (let ((count (length messages)) + (i 1) + (start-point (point-min)) + (waited-for 0)) + (while messages + (process-send-string process (format "%s %d\r\n" command (pop messages))) + ;; Only do 100 messages at a time to avoid pipe stalls. + (when (zerop (% i pop3-stream-length)) + (setq start-point + (pop3-wait-for-messages process pop3-stream-length + total-size start-point)) + (incf waited-for pop3-stream-length)) + (incf i)) + (pop3-wait-for-messages process (- count waited-for) + total-size start-point))) + +(defun pop3-wait-for-messages (process count total-size start-point) + (while (> count 0) + (goto-char start-point) + (while (or (and (re-search-forward "^\\+OK" nil t) + (or (not total-size) + (re-search-forward "^\\.\r?\n" nil t))) + (re-search-forward "^-ERR " nil t)) + (decf count) + (setq start-point (point))) + (unless (memq (process-status process) '(open run)) + (error "pop3 process died")) + (when total-size + (let ((size 0)) + (goto-char (point-min)) + (while (re-search-forward "^\\+OK.*\n" nil t) + (setq size (+ size (- (point)) + (if (re-search-forward "^\\.\r?\n" nil 'move) + (match-beginning 0) + (point))))) + (message "pop3 retrieved %dKB (%d%%)" + (truncate (/ size 1000)) + (truncate (* (/ (* size 1.0) total-size) 100))))) + (pop3-accept-process-output process)) + start-point) + +(defun pop3-write-to-file (file messages) + (let ((pop-buffer (current-buffer)) + (start (point-min)) + beg end + temp-buffer) + (with-temp-buffer + (setq temp-buffer (current-buffer)) + (with-current-buffer pop-buffer + (goto-char (point-min)) + (while (re-search-forward "^\\+OK" nil t) + (forward-line 1) + (setq beg (point)) + (when (re-search-forward "^\\.\r?\n" nil t) + (setq start (point)) + (forward-line -1) + (setq end (point))) + (with-current-buffer temp-buffer + (goto-char (point-max)) + (let ((hstart (point))) + (insert-buffer-substring pop-buffer beg end) + (pop3-clean-region hstart (point)) + (goto-char (point-max)) + (pop3-munge-message-separator hstart (point)) + (when pop3-leave-mail-on-server + (pop3-uidl-add-xheader hstart (pop messages))) + (goto-char (point-max)))))) + (let ((coding-system-for-write 'binary)) + (goto-char (point-min)) + ;; Check whether something inserted a newline at the start and + ;; delete it. + (when (eolp) + (delete-char 1)) + (write-region (point-min) (point-max) file nil 'nomesg))))) + +(defun pop3-logon (process) + (let ((pop3-password pop3-password)) + ;; for debugging only + (if pop3-debug (switch-to-buffer (process-buffer process))) + ;; query for password + (if (and pop3-password-required (not pop3-password)) + (setq pop3-password + (read-passwd (format "Password for %s: " pop3-maildrop)))) + (cond ((equal 'apop pop3-authentication-scheme) + (pop3-apop process pop3-maildrop)) + ((equal 'pass pop3-authentication-scheme) + (pop3-user process pop3-maildrop) + (pop3-pass process)) + (t (error "Invalid POP3 authentication scheme"))))) + +(defun pop3-get-message-count () + "Return the number of messages in the maildrop." + (let* ((process (pop3-open-server pop3-mailhost pop3-port)) + message-count + (pop3-password pop3-password)) + ;; for debugging only + (if pop3-debug (switch-to-buffer (process-buffer process))) + ;; query for password + (if (and pop3-password-required (not pop3-password)) + (setq pop3-password + (read-passwd (format "Password for %s: " pop3-maildrop)))) + (cond ((equal 'apop pop3-authentication-scheme) + (pop3-apop process pop3-maildrop)) + ((equal 'pass pop3-authentication-scheme) + (pop3-user process pop3-maildrop) + (pop3-pass process)) + (t (error "Invalid POP3 authentication scheme"))) + (setq message-count (car (pop3-stat process))) + (pop3-quit process) + message-count)) + +(defun pop3-uidl-stat (process) + "Return a list of unread message numbers and total size." + (pop3-send-command process "UIDL") + (let (err messages size) + (if (condition-case code + (progn + (pop3-read-response process) + t) + (error (setq err (error-message-string code)) + nil)) + (let ((start pop3-read-point) + saved list) + (with-current-buffer (process-buffer process) + (while (not (re-search-forward "^\\.\r\n" nil t)) + (unless (memq (process-status process) '(open run)) + (error "pop3 server closed the connection")) + (pop3-accept-process-output process) + (goto-char start)) + (setq pop3-read-point (point-marker) + pop3-uidl nil) + (while (progn (forward-line -1) (>= (point) start)) + (when (looking-at "[0-9]+ \\([^\n\r ]+\\)") + (push (match-string 1) pop3-uidl))) + (when pop3-uidl + (setq pop3-uidl-saved (pop3-uidl-load) + saved (cdr (assoc pop3-maildrop + (cdr (assoc pop3-mailhost + pop3-uidl-saved))))) + (let ((i (length pop3-uidl))) + (while (> i 0) + (unless (member (nth (1- i) pop3-uidl) saved) + (push i messages)) + (decf i))) + (when messages + (setq list (pop3-list process) + size 0) + (dolist (msg messages) + (setq size (+ size (cdr (assq msg list))))) + (list messages size))))) + (message "%s doesn't support UIDL (%s), so we try a regressive way..." + pop3-mailhost err) + (sit-for 1) + (setq size (pop3-stat process)) + (dotimes (i (car size)) (push (1+ i) messages)) + (setcar size (nreverse messages)) + size))) + +(defun pop3-uidl-dele (process) + "Delete messages according to `pop3-leave-mail-on-server'. +Return non-nil if it is necessary to update the local UIDL file." + (let* ((ctime (current-time)) + (srvr (assoc pop3-mailhost pop3-uidl-saved)) + (saved (assoc pop3-maildrop (cdr srvr))) + i uidl mod new tstamp dele) + (setcdr (cdr ctime) nil) + ;; Add new messages to the data to be saved. + (cond ((and pop3-uidl saved) + (setq i (1- (length pop3-uidl))) + (while (>= i 0) + (unless (member (setq uidl (nth i pop3-uidl)) (cdr saved)) + (push ctime new) + (push uidl new)) + (decf i))) + (pop3-uidl + (setq new (mapcan (lambda (elt) (list elt ctime)) pop3-uidl)))) + (when new (setq mod t)) + ;; List expirable messages and delete them from the data to be saved. + (setq ctime (when (numberp pop3-leave-mail-on-server) + (/ (+ (* (car ctime) 65536.0) (cadr ctime)) 86400)) + i (1- (length saved))) + (while (> i 0) + (if (member (setq uidl (nth (1- i) saved)) pop3-uidl) + (progn + (setq tstamp (nth i saved)) + (if (and ctime + (> (- ctime (/ (+ (* (car tstamp) 65536.0) (cadr tstamp)) + 86400)) + pop3-leave-mail-on-server)) + ;; Mails to delete. + (progn + (setq mod t) + (push uidl dele)) + ;; Mails to keep. + (push tstamp new) + (push uidl new))) + ;; Mails having been deleted in the server. + (setq mod t)) + (decf i 2)) + (cond (saved + (setcdr saved new)) + (srvr + (setcdr (last srvr) (list (cons pop3-maildrop new)))) + (t + (add-to-list 'pop3-uidl-saved + (list pop3-mailhost (cons pop3-maildrop new)) + t))) + ;; Actually delete the messages in the server. + (when dele + (setq uidl nil + i (length pop3-uidl)) + (while (> i 0) + (when (member (nth (1- i) pop3-uidl) dele) + (push i uidl)) + (decf i)) + (when uidl + (pop3-send-streaming-command process "DELE" uidl nil))) + mod)) + +(defun pop3-uidl-load () + "Load saved UIDL." + (when (file-exists-p pop3-uidl-file) + (with-temp-buffer + (condition-case code + (progn + (insert-file-contents pop3-uidl-file) + (goto-char (point-min)) + (read (current-buffer))) + (error + (message "Error while loading %s (%s)" + pop3-uidl-file (error-message-string code)) + (sit-for 1) + nil))))) + +(defun pop3-uidl-save () + "Save UIDL." + (with-temp-buffer + (if pop3-uidl-saved + (progn + (insert "(") + (dolist (srvr pop3-uidl-saved) + (when (cdr srvr) + (insert "(\"" (pop srvr) "\"\n ") + (dolist (elt srvr) + (when (cdr elt) + (insert "(\"" (pop elt) "\"\n ") + (while elt + (insert (format "\"%s\" %s\n " (pop elt) (pop elt)))) + (delete-char -4) + (insert ")\n "))) + (delete-char -3) + (if (eq (char-before) ?\)) + (insert ")\n ") + (goto-char (1+ (point-at-bol))) + (delete-region (point) (point-max))))) + (when (eq (char-before) ? ) + (delete-char -2)) + (insert ")\n")) + (insert "()\n")) + (let ((buffer-file-name pop3-uidl-file) + (delete-old-versions t) + (kept-new-versions kept-new-versions) + (kept-old-versions kept-old-versions) + (version-control version-control)) + (if (consp pop3-uidl-file-backup) + (setq kept-new-versions (cadr pop3-uidl-file-backup) + kept-old-versions (car pop3-uidl-file-backup) + version-control t) + (setq version-control pop3-uidl-file-backup)) + (save-buffer)))) + +(defun pop3-uidl-add-xheader (start msgno) + "Add X-UIDL header." + (let ((case-fold-search t)) + (save-restriction + (narrow-to-region start (progn + (goto-char start) + (search-forward "\n\n" nil 'move) + (1- (point)))) + (goto-char start) + (while (re-search-forward "^x-uidl:" nil t) + (while (progn + (forward-line 1) + (memq (char-after) '(?\t ? )))) + (delete-region (match-beginning 0) (point))) + (goto-char (point-max)) + (insert "X-UIDL: " (nth (1- msgno) pop3-uidl) "\n")))) + +(defcustom pop3-stream-type nil + "Transport security type for POP3 connections. +This may be either nil (plain connection), `ssl' (use an +SSL/TSL-secured stream) or `starttls' (use the starttls mechanism +to turn on TLS security after opening the stream). However, if +this is nil, `ssl' is assumed for connections to port +995 (pop3s)." + :version "23.1" ;; No Gnus + :group 'pop3 + :type '(choice (const :tag "Plain" nil) + (const :tag "SSL/TLS" ssl) + (const starttls))) + +(defun pop3-open-server (mailhost port) + "Open TCP connection to MAILHOST on PORT. +Returns the process associated with the connection." + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary) + result) + (with-current-buffer + (get-buffer-create (concat " trace of POP session to " + mailhost)) + (erase-buffer) + (setq pop3-read-point (point-min)) + (setq result + (open-network-stream + "POP" (current-buffer) mailhost port + :type (cond + ((or (eq pop3-stream-type 'ssl) + (and (not pop3-stream-type) + (member port '(995 "pop3s")))) + 'tls) + (t + (or pop3-stream-type 'network))) + :warn-unless-encrypted t + :capability-command "CAPA\r\n" + :end-of-command "^\\(-ERR\\|+OK\\).*\n" + :end-of-capability "^\\.\r?\n\\|^-ERR" + :success "^\\+OK.*\n" + :return-list t + :starttls-function + (lambda (capabilities) + (and (string-match "\\bSTLS\\b" capabilities) + "STLS\r\n")))) + (when result + (let ((response (plist-get (cdr result) :greeting))) + (setq pop3-timestamp + (substring response (or (string-match "<" response) 0) + (+ 1 (or (string-match ">" response) -1))))) + (set-process-query-on-exit-flag (car result) nil) + (erase-buffer) + (car result))))) + +;; Support functions + +(defun pop3-send-command (process command) + (set-buffer (process-buffer process)) + (goto-char (point-max)) + ;; (if (= (aref command 0) ?P) + ;; (insert "PASS \r\n") + ;; (insert command "\r\n")) + (setq pop3-read-point (point)) + (goto-char (point-max)) + (process-send-string process (concat command "\r\n"))) + +(defun pop3-read-response (process &optional return) + "Read the response from the server. +Return the response string if optional second argument is non-nil." + (let ((case-fold-search nil) + match-end) + (with-current-buffer (process-buffer process) + (goto-char pop3-read-point) + (while (and (memq (process-status process) '(open run)) + (not (search-forward "\r\n" nil t))) + (pop3-accept-process-output process) + (goto-char pop3-read-point)) + (setq match-end (point)) + (goto-char pop3-read-point) + (if (looking-at "-ERR") + (error "%s" (buffer-substring (point) (- match-end 2))) + (if (not (looking-at "+OK")) + (progn (setq pop3-read-point match-end) nil) + (setq pop3-read-point match-end) + (if return + (buffer-substring (point) match-end) + t) + ))))) + +(defun pop3-clean-region (start end) + (setq end (set-marker (make-marker) end)) + (save-excursion + (goto-char start) + (while (and (< (point) end) (search-forward "\r\n" end t)) + (replace-match "\n" t t)) + (goto-char start) + (while (and (< (point) end) (re-search-forward "^\\." end t)) + (replace-match "" t t) + (forward-char))) + (set-marker end nil)) + +;; Copied from message-make-date. +(defun pop3-make-date (&optional now) + "Make a valid date header. +If NOW, use that time instead." + (require 'parse-time) + (let* ((now (or now (current-time))) + (zone (nth 8 (decode-time now))) + (sign "+")) + (when (< zone 0) + (setq sign "-") + (setq zone (- zone))) + (concat + (format-time-string "%d" now) + ;; The month name of the %b spec is locale-specific. Pfff. + (format " %s " + (capitalize (car (rassoc (nth 4 (decode-time now)) + parse-time-months)))) + (format-time-string "%Y %H:%M:%S %z" now)))) + +(defun pop3-munge-message-separator (start end) + "Check to see if a message separator exists. If not, generate one." + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (if (not (or (looking-at "From .?") ; Unix mail + (looking-at "\001\001\001\001\n") ; MMDF + (looking-at "BABYL OPTIONS:") ; Babyl + )) + (let* ((from (mail-strip-quoted-names (mail-fetch-field "From"))) + (tdate (mail-fetch-field "Date")) + (date (split-string (or (and tdate + (not (string= "" tdate)) + tdate) + (pop3-make-date)) + " ")) + (From_)) + ;; sample date formats I have seen + ;; Date: Tue, 9 Jul 1996 09:04:21 -0400 (EDT) + ;; Date: 08 Jul 1996 23:22:24 -0400 + ;; should be + ;; Tue Jul 9 09:04:21 1996 + + ;; Fixme: This should use timezone on the date field contents. + (setq date + (cond ((not date) + "Tue Jan 1 00:00:0 1900") + ((string-match "[A-Z]" (nth 0 date)) + (format "%s %s %s %s %s" + (nth 0 date) (nth 2 date) (nth 1 date) + (nth 4 date) (nth 3 date))) + (t + ;; this really needs to be better but I don't feel + ;; like writing a date to day converter. + (format "Sun %s %s %s %s" + (nth 1 date) (nth 0 date) + (nth 3 date) (nth 2 date))) + )) + (setq From_ (format "\nFrom %s %s\n" from date)) + (while (string-match "," From_) + (setq From_ (concat (substring From_ 0 (match-beginning 0)) + (substring From_ (match-end 0))))) + (goto-char (point-min)) + (insert From_) + (if (search-forward "\n\n" nil t) + nil + (goto-char (point-max)) + (insert "\n")) + (let ((size (- (point-max) (point)))) + (forward-line -1) + (insert (format "Content-Length: %s\n" size))) + ))))) + +;; The Command Set + +;; AUTHORIZATION STATE + +(defun pop3-user (process user) + "Send USER information to POP3 server." + (pop3-send-command process (format "USER %s" user)) + (let ((response (pop3-read-response process t))) + (if (not (and response (string-match "+OK" response))) + (error "USER %s not valid" user)))) + +(defun pop3-pass (process) + "Send authentication information to the server." + (pop3-send-command process (format "PASS %s" pop3-password)) + (let ((response (pop3-read-response process t))) + (if (not (and response (string-match "+OK" response))) + (pop3-quit process)))) + +(defun pop3-apop (process user) + "Send alternate authentication information to the server." + (let ((pass pop3-password)) + (if (and pop3-password-required (not pass)) + (setq pass + (read-passwd (format "Password for %s: " pop3-maildrop)))) + (if pass + (let ((hash (md5 (concat pop3-timestamp pass) nil nil 'binary))) + (pop3-send-command process (format "APOP %s %s" user hash)) + (let ((response (pop3-read-response process t))) + (if (not (and response (string-match "+OK" response))) + (pop3-quit process))))) + )) + +;; TRANSACTION STATE + +(defun pop3-stat (process) + "Return the number of messages in the maildrop and the maildrop's size." + (pop3-send-command process "STAT") + (let ((response (pop3-read-response process t))) + (list (string-to-number (nth 1 (split-string response " "))) + (string-to-number (nth 2 (split-string response " ")))) + )) + +(defun pop3-list (process &optional msg) + "If MSG is nil, return an alist of (MESSAGE-ID . SIZE) pairs. +Otherwise, return the size of the message-id MSG" + (pop3-send-command process (if msg + (format "LIST %d" msg) + "LIST")) + (let ((response (pop3-read-response process t))) + (if msg + (string-to-number (nth 2 (split-string response " "))) + (let ((start pop3-read-point) end) + (with-current-buffer (process-buffer process) + (while (not (re-search-forward "^\\.\r\n" nil t)) + (pop3-accept-process-output process) + (goto-char start)) + (setq pop3-read-point (point-marker)) + (goto-char (match-beginning 0)) + (setq end (point-marker)) + (mapcar #'(lambda (s) (let ((split (split-string s " "))) + (cons (string-to-number (nth 0 split)) + (string-to-number (nth 1 split))))) + (split-string (buffer-substring start end) "\r\n" t))))))) + +(defun pop3-retr (process msg crashbuf) + "Retrieve message-id MSG to buffer CRASHBUF." + (pop3-send-command process (format "RETR %s" msg)) + (pop3-read-response process) + (let ((start pop3-read-point) end) + (with-current-buffer (process-buffer process) + (while (not (re-search-forward "^\\.\r\n" nil t)) + (unless (memq (process-status process) '(open run)) + (error "pop3 server closed the connection")) + (pop3-accept-process-output process) + (goto-char start)) + (setq pop3-read-point (point-marker)) + ;; this code does not seem to work for some POP servers... + ;; and I cannot figure out why not. + ;; (goto-char (match-beginning 0)) + ;; (backward-char 2) + ;; (if (not (looking-at "\r\n")) + ;; (insert "\r\n")) + ;; (re-search-forward "\\.\r\n") + (goto-char (match-beginning 0)) + (setq end (point-marker)) + (pop3-clean-region start end) + (pop3-munge-message-separator start end) + (with-current-buffer crashbuf + (erase-buffer)) + (copy-to-buffer crashbuf start end) + (delete-region start end) + ))) + +(defun pop3-dele (process msg) + "Mark message-id MSG as deleted." + (pop3-send-command process (format "DELE %s" msg)) + (pop3-read-response process)) + +(defun pop3-noop (process msg) + "No-operation." + (pop3-send-command process "NOOP") + (pop3-read-response process)) + +(defun pop3-last (process) + "Return highest accessed message-id number for the session." + (pop3-send-command process "LAST") + (let ((response (pop3-read-response process t))) + (string-to-number (nth 1 (split-string response " "))) + )) + +(defun pop3-rset (process) + "Remove all delete marks from current maildrop." + (pop3-send-command process "RSET") + (pop3-read-response process)) + +;; UPDATE + +(defun pop3-quit (process) + "Close connection to POP3 server. +Tell server to remove all messages marked as deleted, unlock the maildrop, +and close the connection." + (pop3-send-command process "QUIT") + (pop3-read-response process t) + (if process + (with-current-buffer (process-buffer process) + (goto-char (point-max)) + (delete-process process)))) + +;; Summary of POP3 (Post Office Protocol version 3) commands and responses + +;;; AUTHORIZATION STATE + +;; Initial TCP connection +;; Arguments: none +;; Restrictions: none +;; Possible responses: +;; +OK [POP3 server ready] + +;; USER name +;; Arguments: a server specific user-id (required) +;; Restrictions: authorization state [after unsuccessful USER or PASS +;; Possible responses: +;; +OK [valid user-id] +;; -ERR [invalid user-id] + +;; PASS string +;; Arguments: a server/user-id specific password (required) +;; Restrictions: authorization state, after successful USER +;; Possible responses: +;; +OK [maildrop locked and ready] +;; -ERR [invalid password] +;; -ERR [unable to lock maildrop] + +;; STLS (RFC 2595) +;; Arguments: none +;; Restrictions: Only permitted in AUTHORIZATION state. +;; Possible responses: +;; +OK +;; -ERR + +;;; TRANSACTION STATE + +;; STAT +;; Arguments: none +;; Restrictions: transaction state +;; Possible responses: +;; +OK nn mm [# of messages, size of maildrop] + +;; LIST [msg] +;; Arguments: a message-id (optional) +;; Restrictions: transaction state; msg must not be deleted +;; Possible responses: +;; +OK [scan listing follows] +;; -ERR [no such message] + +;; RETR msg +;; Arguments: a message-id (required) +;; Restrictions: transaction state; msg must not be deleted +;; Possible responses: +;; +OK [message contents follow] +;; -ERR [no such message] + +;; DELE msg +;; Arguments: a message-id (required) +;; Restrictions: transaction state; msg must not be deleted +;; Possible responses: +;; +OK [message deleted] +;; -ERR [no such message] + +;; NOOP +;; Arguments: none +;; Restrictions: transaction state +;; Possible responses: +;; +OK + +;; LAST +;; Arguments: none +;; Restrictions: transaction state +;; Possible responses: +;; +OK nn [highest numbered message accessed] + +;; RSET +;; Arguments: none +;; Restrictions: transaction state +;; Possible responses: +;; +OK [all delete marks removed] + +;; UIDL [msg] +;; Arguments: a message-id (optional) +;; Restrictions: transaction state; msg must not be deleted +;; Possible responses: +;; +OK [uidl listing follows] +;; -ERR [no such message] + +;;; UPDATE STATE + +;; QUIT +;; Arguments: none +;; Restrictions: none +;; Possible responses: +;; +OK [TCP connection closed] + +(provide 'pop3) + +;;; pop3.el ends here diff --cc lisp/net/secrets.el index ea26a521afd,cd565880745..4d6e48ba2e0 --- a/lisp/net/secrets.el +++ b/lisp/net/secrets.el @@@ -1,6 -1,6 +1,6 @@@ -;;; secrets.el --- Client interface to gnome-keyring and kwallet. +;;; secrets.el --- Client interface to gnome-keyring and kwallet. -*- lexical-binding: t -*- - ;; Copyright (C) 2010-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2010-2017 Free Software Foundation, Inc. ;; Author: Michael Albinus ;; Keywords: comm password passphrase diff --cc lisp/net/shr.el index 9ea143da335,6c35a33c9c3..e0bb3dbb2b7 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@@ -1,6 -1,6 +1,6 @@@ -;;; shr.el --- Simple HTML Renderer +;;; shr.el --- Simple HTML Renderer -*- lexical-binding: t -*- - ;; Copyright (C) 2010-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2010-2017 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: html diff --cc lisp/net/sieve-manage.el index 8f7bd449284,00000000000..1a54e1aa738 mode 100644,000000..100644 --- a/lisp/net/sieve-manage.el +++ b/lisp/net/sieve-manage.el @@@ -1,583 -1,0 +1,583 @@@ +;;; sieve-manage.el --- Implementation of the managesieve protocol in elisp + - ;; Copyright (C) 2001-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2001-2017 Free Software Foundation, Inc. + +;; Author: Simon Josefsson +;; Albert Krewinkel + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This library provides an elisp API for the managesieve network +;; protocol. +;; +;; It uses the SASL library for authentication, which means it +;; supports DIGEST-MD5, CRAM-MD5, SCRAM-MD5, NTLM, PLAIN and LOGIN +;; methods. STARTTLS is not well tested, but should be easy to get to +;; work if someone wants. +;; +;; The API should be fairly obvious for anyone familiar with the +;; managesieve protocol, interface functions include: +;; +;; `sieve-manage-open' +;; open connection to managesieve server, returning a buffer to be +;; used by all other API functions. +;; +;; `sieve-manage-opened' +;; check if a server is open or not +;; +;; `sieve-manage-close' +;; close a server connection. +;; +;; `sieve-manage-listscripts' +;; `sieve-manage-deletescript' +;; `sieve-manage-getscript' +;; performs managesieve protocol actions +;; +;; and that's it. Example of a managesieve session in *scratch*: +;; +;; (with-current-buffer (sieve-manage-open "mail.example.com") +;; (sieve-manage-authenticate) +;; (sieve-manage-listscripts)) +;; +;; => ((active . "main") "vacation") +;; +;; References: +;; +;; draft-martin-managesieve-02.txt, +;; "A Protocol for Remotely Managing Sieve Scripts", +;; by Tim Martin. +;; +;; Release history: +;; +;; 2001-10-31 Committed to Oort Gnus. +;; 2002-07-27 Added DELETESCRIPT. Suggested by Ned Ludd. +;; 2002-08-03 Use SASL library. +;; 2013-06-05 Enabled STARTTLS support, fixed bit rot. + +;;; Code: + +(if (locate-library "password-cache") + (require 'password-cache) + (require 'password)) + +(eval-when-compile (require 'cl)) +(require 'sasl) +(require 'starttls) +(autoload 'sasl-find-mechanism "sasl") +(autoload 'auth-source-search "auth-source") + +;; User customizable variables: + +(defgroup sieve-manage nil + "Low-level Managesieve protocol issues." + :group 'mail + :prefix "sieve-") + +(defcustom sieve-manage-log "*sieve-manage-log*" + "Name of buffer for managesieve session trace." + :type 'string + :group 'sieve-manage) + +(defcustom sieve-manage-server-eol "\r\n" + "The EOL string sent from the server." + :type 'string + :group 'sieve-manage) + +(defcustom sieve-manage-client-eol "\r\n" + "The EOL string we send to the server." + :type 'string + :group 'sieve-manage) + +(defcustom sieve-manage-authenticators '(digest-md5 + cram-md5 + scram-md5 + ntlm + plain + login) + "Priority of authenticators to consider when authenticating to server." + ;; FIXME Improve this. It's not `set'. + ;; It's like (repeat (choice (const ...))), where each choice can + ;; only appear once. + :type '(repeat symbol) + :group 'sieve-manage) + +(defcustom sieve-manage-authenticator-alist + '((cram-md5 sieve-manage-cram-md5-p sieve-manage-cram-md5-auth) + (digest-md5 sieve-manage-digest-md5-p sieve-manage-digest-md5-auth) + (scram-md5 sieve-manage-scram-md5-p sieve-manage-scram-md5-auth) + (ntlm sieve-manage-ntlm-p sieve-manage-ntlm-auth) + (plain sieve-manage-plain-p sieve-manage-plain-auth) + (login sieve-manage-login-p sieve-manage-login-auth)) + "Definition of authenticators. + +\(NAME CHECK AUTHENTICATE) + +NAME names the authenticator. CHECK is a function returning non-nil if +the server support the authenticator and AUTHENTICATE is a function +for doing the actual authentication." + :type '(repeat (list (symbol :tag "Name") (function :tag "Check function") + (function :tag "Authentication function"))) + :group 'sieve-manage) + +(defcustom sieve-manage-default-port "sieve" + "Default port number or service name for managesieve protocol." + :type '(choice integer string) + :version "24.4" + :group 'sieve-manage) + +(defcustom sieve-manage-default-stream 'network + "Default stream type to use for `sieve-manage'." + :version "24.1" + :type 'symbol + :group 'sieve-manage) + +(defcustom sieve-manage-ignore-starttls nil + "Ignore STARTTLS even if STARTTLS capability is provided." + :version "26.1" + :type 'boolean + :group 'sieve-manage) + +;; Internal variables: + +(defconst sieve-manage-local-variables '(sieve-manage-server + sieve-manage-port + sieve-manage-auth + sieve-manage-stream + sieve-manage-process + sieve-manage-client-eol + sieve-manage-server-eol + sieve-manage-capability)) +(defconst sieve-manage-coding-system-for-read 'binary) +(defconst sieve-manage-coding-system-for-write 'binary) +(defvar sieve-manage-stream nil) +(defvar sieve-manage-auth nil) +(defvar sieve-manage-server nil) +(defvar sieve-manage-port nil) +(defvar sieve-manage-state 'closed + "Managesieve state. +Valid states are `closed', `initial', `nonauth', and `auth'.") +(defvar sieve-manage-process nil) +(defvar sieve-manage-capability nil) + +;; Internal utility functions +(autoload 'mm-enable-multibyte "mm-util") + +(defun sieve-manage-make-process-buffer () + (with-current-buffer + (generate-new-buffer (format " *sieve %s:%s*" + sieve-manage-server + sieve-manage-port)) + (mapc 'make-local-variable sieve-manage-local-variables) + (mm-enable-multibyte) + (buffer-disable-undo) + (current-buffer))) + +(defun sieve-manage-erase (&optional p buffer) + (let ((buffer (or buffer (current-buffer)))) + (and sieve-manage-log + (with-current-buffer (get-buffer-create sieve-manage-log) + (mm-enable-multibyte) + (buffer-disable-undo) + (goto-char (point-max)) + (insert-buffer-substring buffer (with-current-buffer buffer + (point-min)) + (or p (with-current-buffer buffer + (point-max))))))) + (delete-region (point-min) (or p (point-max)))) + +(defun sieve-manage-open-server (server port &optional stream buffer) + "Open network connection to SERVER on PORT. +Return the buffer associated with the connection." + (with-current-buffer buffer + (sieve-manage-erase) + (setq sieve-manage-state 'initial) + (destructuring-bind (proc . props) + (open-network-stream + "SIEVE" buffer server port + :type stream + :capability-command "CAPABILITY\r\n" + :end-of-command "^\\(OK\\|NO\\).*\n" + :success "^OK.*\n" + :return-list t + :starttls-function + (lambda (capabilities) + (when (and (not sieve-manage-ignore-starttls) + (string-match "\\bSTARTTLS\\b" capabilities)) + "STARTTLS\r\n"))) + (setq sieve-manage-process proc) + (setq sieve-manage-capability + (sieve-manage-parse-capability (plist-get props :capabilities))) + ;; Ignore new capabilities issues after successful STARTTLS + (when (or sieve-manage-ignore-starttls + (and (memq stream '(nil network starttls)) + (eq (plist-get props :type) 'tls))) + (sieve-manage-drop-next-answer)) + (current-buffer)))) + +;; Authenticators +(defun sieve-sasl-auth (buffer mech) + "Login to server using the SASL MECH method." + (message "sieve: Authenticating using %s..." mech) + (with-current-buffer buffer + (let* ((auth-info (auth-source-search :host sieve-manage-server + :port "sieve" + :max 1 + :create t)) + (user-name (or (plist-get (nth 0 auth-info) :user) "")) + (user-password (or (plist-get (nth 0 auth-info) :secret) "")) + (user-password (if (functionp user-password) + (funcall user-password) + user-password)) + (client (sasl-make-client (sasl-find-mechanism (list mech)) + user-name "sieve" sieve-manage-server)) + (sasl-read-passphrase + ;; We *need* to copy the password, because sasl will modify it + ;; somehow. + `(lambda (prompt) ,(copy-sequence user-password))) + (step (sasl-next-step client nil)) + (tag (sieve-manage-send + (concat + "AUTHENTICATE \"" + mech + "\"" + (and (sasl-step-data step) + (concat + " \"" + (base64-encode-string + (sasl-step-data step) + 'no-line-break) + "\""))))) + data rsp) + (catch 'done + (while t + (setq rsp nil) + (goto-char (point-min)) + (while (null (or (progn + (setq rsp (sieve-manage-is-string)) + (if (not (and rsp (looking-at + sieve-manage-server-eol))) + (setq rsp nil) + (goto-char (match-end 0)) + rsp)) + (setq rsp (sieve-manage-is-okno)))) + (accept-process-output sieve-manage-process 1) + (goto-char (point-min))) + (sieve-manage-erase) + (when (sieve-manage-ok-p rsp) + (when (and (cadr rsp) + (string-match "^SASL \"\\([^\"]+\\)\"" (cadr rsp))) + (sasl-step-set-data + step (base64-decode-string (match-string 1 (cadr rsp))))) + (if (and (setq step (sasl-next-step client step)) + (setq data (sasl-step-data step))) + ;; We got data for server but it's finished + (error "Server not ready for SASL data: %s" data) + ;; The authentication process is finished. + (throw 'done t))) + (unless (stringp rsp) + (error "Server aborted SASL authentication: %s" (caddr rsp))) + (sasl-step-set-data step (base64-decode-string rsp)) + (setq step (sasl-next-step client step)) + (sieve-manage-send + (if (sasl-step-data step) + (concat "\"" + (base64-encode-string (sasl-step-data step) + 'no-line-break) + "\"") + "")))) + (message "sieve: Login using %s...done" mech)))) + +(defun sieve-manage-cram-md5-p (buffer) + (sieve-manage-capability "SASL" "CRAM-MD5" buffer)) + +(defun sieve-manage-cram-md5-auth (buffer) + "Login to managesieve server using the CRAM-MD5 SASL method." + (sieve-sasl-auth buffer "CRAM-MD5")) + +(defun sieve-manage-digest-md5-p (buffer) + (sieve-manage-capability "SASL" "DIGEST-MD5" buffer)) + +(defun sieve-manage-digest-md5-auth (buffer) + "Login to managesieve server using the DIGEST-MD5 SASL method." + (sieve-sasl-auth buffer "DIGEST-MD5")) + +(defun sieve-manage-scram-md5-p (buffer) + (sieve-manage-capability "SASL" "SCRAM-MD5" buffer)) + +(defun sieve-manage-scram-md5-auth (buffer) + "Login to managesieve server using the SCRAM-MD5 SASL method." + (sieve-sasl-auth buffer "SCRAM-MD5")) + +(defun sieve-manage-ntlm-p (buffer) + (sieve-manage-capability "SASL" "NTLM" buffer)) + +(defun sieve-manage-ntlm-auth (buffer) + "Login to managesieve server using the NTLM SASL method." + (sieve-sasl-auth buffer "NTLM")) + +(defun sieve-manage-plain-p (buffer) + (sieve-manage-capability "SASL" "PLAIN" buffer)) + +(defun sieve-manage-plain-auth (buffer) + "Login to managesieve server using the PLAIN SASL method." + (sieve-sasl-auth buffer "PLAIN")) + +(defun sieve-manage-login-p (buffer) + (sieve-manage-capability "SASL" "LOGIN" buffer)) + +(defun sieve-manage-login-auth (buffer) + "Login to managesieve server using the LOGIN SASL method." + (sieve-sasl-auth buffer "LOGIN")) + +;; Managesieve API + +(defun sieve-manage-open (server &optional port stream auth buffer) + "Open a network connection to a managesieve SERVER (string). +Optional argument PORT is port number (integer) on remote server. +Optional argument STREAM is any of `sieve-manage-streams' (a symbol). +Optional argument AUTH indicates authenticator to use, see +`sieve-manage-authenticators' for available authenticators. +If nil, chooses the best stream the server is capable of. +Optional argument BUFFER is buffer (buffer, or string naming buffer) +to work in." + (setq sieve-manage-port (or port sieve-manage-default-port)) + (with-current-buffer (or buffer (sieve-manage-make-process-buffer)) + (setq sieve-manage-server (or server + sieve-manage-server) + sieve-manage-stream (or stream + sieve-manage-stream + sieve-manage-default-stream) + sieve-manage-auth (or auth + sieve-manage-auth)) + (message "sieve: Connecting to %s..." sieve-manage-server) + (sieve-manage-open-server sieve-manage-server + sieve-manage-port + sieve-manage-stream + (current-buffer)) + (when (sieve-manage-opened (current-buffer)) + ;; Choose authenticator + (when (and (null sieve-manage-auth) + (not (eq sieve-manage-state 'auth))) + (dolist (auth sieve-manage-authenticators) + (when (funcall (nth 1 (assq auth sieve-manage-authenticator-alist)) + buffer) + (setq sieve-manage-auth auth) + (return))) + (unless sieve-manage-auth + (error "Couldn't figure out authenticator for server"))) + (sieve-manage-erase) + (current-buffer)))) + +(defun sieve-manage-authenticate (&optional buffer) + "Authenticate on server in BUFFER. +Return `sieve-manage-state' value." + (with-current-buffer (or buffer (current-buffer)) + (if (eq sieve-manage-state 'nonauth) + (when (funcall (nth 2 (assq sieve-manage-auth + sieve-manage-authenticator-alist)) + (current-buffer)) + (setq sieve-manage-state 'auth)) + sieve-manage-state))) + +(defun sieve-manage-opened (&optional buffer) + "Return non-nil if connection to managesieve server in BUFFER is open. +If BUFFER is nil then the current buffer is used." + (and (setq buffer (get-buffer (or buffer (current-buffer)))) + (buffer-live-p buffer) + (with-current-buffer buffer + (and sieve-manage-process + (memq (process-status sieve-manage-process) '(open run)))))) + +(defun sieve-manage-close (&optional buffer) + "Close connection to managesieve server in BUFFER. +If BUFFER is nil, the current buffer is used." + (with-current-buffer (or buffer (current-buffer)) + (when (sieve-manage-opened) + (sieve-manage-send "LOGOUT") + (sit-for 1)) + (when (and sieve-manage-process + (memq (process-status sieve-manage-process) '(open run))) + (delete-process sieve-manage-process)) + (setq sieve-manage-process nil) + (sieve-manage-erase) + t)) + +(defun sieve-manage-capability (&optional name value buffer) + "Check if capability NAME of server BUFFER match VALUE. +If it does, return the server value of NAME. If not returns nil. +If VALUE is nil, do not check VALUE and return server value. +If NAME is nil, return the full server list of capabilities." + (with-current-buffer (or buffer (current-buffer)) + (if (null name) + sieve-manage-capability + (let ((server-value (cadr (assoc name sieve-manage-capability)))) + (when (or (null value) + (and server-value + (string-match value server-value))) + server-value))))) + +(defun sieve-manage-listscripts (&optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (sieve-manage-send "LISTSCRIPTS") + (sieve-manage-parse-listscripts))) + +(defun sieve-manage-havespace (name size &optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (sieve-manage-send (format "HAVESPACE \"%s\" %s" name size)) + (sieve-manage-parse-okno))) + +(defun sieve-manage-putscript (name content &optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (sieve-manage-send (format "PUTSCRIPT \"%s\" {%d+}%s%s" name + ;; Here we assume that the coding-system will + ;; replace each char with a single byte. + ;; This is always the case if `content' is + ;; a unibyte string. + (length content) + sieve-manage-client-eol content)) + (sieve-manage-parse-okno))) + +(defun sieve-manage-deletescript (name &optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (sieve-manage-send (format "DELETESCRIPT \"%s\"" name)) + (sieve-manage-parse-okno))) + +(defun sieve-manage-getscript (name output-buffer &optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (sieve-manage-send (format "GETSCRIPT \"%s\"" name)) + (let ((script (sieve-manage-parse-string))) + (sieve-manage-parse-crlf) + (with-current-buffer output-buffer + (insert script)) + (sieve-manage-parse-okno)))) + +(defun sieve-manage-setactive (name &optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (sieve-manage-send (format "SETACTIVE \"%s\"" name)) + (sieve-manage-parse-okno))) + +;; Protocol parsing routines + +(defun sieve-manage-wait-for-answer () + (let ((pattern "^\\(OK\\|NO\\).*\n") + pos) + (while (not pos) + (setq pos (search-forward-regexp pattern nil t)) + (goto-char (point-min)) + (sleep-for 0 50)) + pos)) + +(defun sieve-manage-drop-next-answer () + (sieve-manage-wait-for-answer) + (sieve-manage-erase)) + +(defun sieve-manage-ok-p (rsp) + (string= (downcase (or (car-safe rsp) "")) "ok")) + +(defun sieve-manage-is-okno () + (when (looking-at (concat + "^\\(OK\\|NO\\)\\( (\\([^)]+\\))\\)?\\( \\(.*\\)\\)?" + sieve-manage-server-eol)) + (let ((status (match-string 1)) + (resp-code (match-string 3)) + (response (match-string 5))) + (when response + (goto-char (match-beginning 5)) + (setq response (sieve-manage-is-string))) + (list status resp-code response)))) + +(defun sieve-manage-parse-okno () + (let (rsp) + (while (null rsp) + (accept-process-output (get-buffer-process (current-buffer)) 1) + (goto-char (point-min)) + (setq rsp (sieve-manage-is-okno))) + (sieve-manage-erase) + rsp)) + +(defun sieve-manage-parse-capability (str) + "Parse managesieve capability string `STR'. +Set variable `sieve-manage-capability' to " + (let ((capas (delq nil + (mapcar #'split-string-and-unquote + (split-string str "\n"))))) + (when (string= "OK" (caar (last capas))) + (setq sieve-manage-state 'nonauth)) + capas)) + +(defun sieve-manage-is-string () + (cond ((looking-at "\"\\([^\"]+\\)\"") + (prog1 + (match-string 1) + (goto-char (match-end 0)))) + ((looking-at (concat "{\\([0-9]+\\+?\\)}" sieve-manage-server-eol)) + (let ((pos (match-end 0)) + (len (string-to-number (match-string 1)))) + (if (< (point-max) (+ pos len)) + nil + (goto-char (+ pos len)) + (buffer-substring pos (+ pos len))))))) + +(defun sieve-manage-parse-string () + (let (rsp) + (while (null rsp) + (accept-process-output (get-buffer-process (current-buffer)) 1) + (goto-char (point-min)) + (setq rsp (sieve-manage-is-string))) + (sieve-manage-erase (point)) + rsp)) + +(defun sieve-manage-parse-crlf () + (when (looking-at sieve-manage-server-eol) + (sieve-manage-erase (match-end 0)))) + +(defun sieve-manage-parse-listscripts () + (let (tmp rsp data) + (while (null rsp) + (while (null (or (setq rsp (sieve-manage-is-okno)) + (setq tmp (sieve-manage-is-string)))) + (accept-process-output (get-buffer-process (current-buffer)) 1) + (goto-char (point-min))) + (when tmp + (while (not (looking-at (concat "\\( ACTIVE\\)?" + sieve-manage-server-eol))) + (accept-process-output (get-buffer-process (current-buffer)) 1) + (goto-char (point-min))) + (if (match-string 1) + (push (cons 'active tmp) data) + (push tmp data)) + (goto-char (match-end 0)) + (setq tmp nil))) + (sieve-manage-erase) + (if (sieve-manage-ok-p rsp) + data + rsp))) + +(defun sieve-manage-send (cmdstr) + (setq cmdstr (concat cmdstr sieve-manage-client-eol)) + (and sieve-manage-log + (with-current-buffer (get-buffer-create sieve-manage-log) + (mm-enable-multibyte) + (buffer-disable-undo) + (goto-char (point-max)) + (insert cmdstr))) + (process-send-string sieve-manage-process cmdstr)) + +(provide 'sieve-manage) + +;; sieve-manage.el ends here diff --cc lisp/net/sieve-mode.el index 6aa1b207ee2,00000000000..87bb3a245b8 mode 100644,000000..100644 --- a/lisp/net/sieve-mode.el +++ b/lisp/net/sieve-mode.el @@@ -1,212 -1,0 +1,212 @@@ +;;; sieve-mode.el --- Sieve code editing commands for Emacs + - ;; Copyright (C) 2001-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2001-2017 Free Software Foundation, Inc. + +;; Author: Simon Josefsson + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This file contain editing mode functions and font-lock support for +;; editing Sieve scripts. It sets up C-mode with support for +;; sieve-style #-comments and a lightly hacked syntax table. It was +;; strongly influenced by awk-mode.el. +;; +;; Put something similar to the following in your .emacs to use this file: +;; +;; (load "~/lisp/sieve") +;; (setq auto-mode-alist (cons '("\\.siv\\'" . sieve-mode) auto-mode-alist)) +;; +;; References: +;; +;; RFC 3028, +;; "Sieve: A Mail Filtering Language", +;; by Tim Showalter. +;; +;; Release history: +;; +;; 2001-03-02 version 1.0 posted to gnu.emacs.sources +;; version 1.1 change file extension into ".siv" (official one) +;; added keymap and menubar to hook into sieve-manage +;; 2001-10-31 version 1.2 committed to Oort Gnus + +;;; Code: + +(autoload 'sieve-manage "sieve") +(autoload 'sieve-upload "sieve") +(eval-when-compile + (require 'font-lock)) + +(defgroup sieve nil + "Sieve." + :group 'languages) + +(defcustom sieve-mode-hook nil + "Hook run in sieve mode buffers." + :type 'hook) + +;; Font-lock + +(defface sieve-control-commands + '((((type tty) (class color)) (:foreground "blue" :weight light)) + (((class grayscale) (background light)) (:foreground "LightGray" :bold t)) + (((class grayscale) (background dark)) (:foreground "DimGray" :bold t)) + (((class color) (background light)) (:foreground "Orchid")) + (((class color) (background dark)) (:foreground "LightSteelBlue")) + (t (:bold t))) + "Face used for Sieve Control Commands.") + +(defface sieve-action-commands + '((((type tty) (class color)) (:foreground "blue" :weight bold)) + (((class color) (background light)) (:foreground "Blue")) + (((class color) (background dark)) (:foreground "LightSkyBlue")) + (t (:inverse-video t :bold t))) + "Face used for Sieve Action Commands.") + +(defface sieve-test-commands + '((((type tty) (class color)) (:foreground "magenta")) + (((class grayscale) (background light)) + (:foreground "LightGray" :bold t :underline t)) + (((class grayscale) (background dark)) + (:foreground "Gray50" :bold t :underline t)) + (((class color) (background light)) (:foreground "CadetBlue")) + (((class color) (background dark)) (:foreground "Aquamarine")) + (t (:bold t :underline t))) + "Face used for Sieve Test Commands.") + +(defface sieve-tagged-arguments + '((((type tty) (class color)) (:foreground "cyan" :weight bold)) + (((class grayscale) (background light)) (:foreground "LightGray" :bold t)) + (((class grayscale) (background dark)) (:foreground "DimGray" :bold t)) + (((class color) (background light)) (:foreground "Purple")) + (((class color) (background dark)) (:foreground "Cyan")) + (t (:bold t))) + "Face used for Sieve Tagged Arguments.") + + +(defconst sieve-font-lock-keywords + (eval-when-compile + (list + ;; control commands + (cons (regexp-opt '("require" "if" "else" "elsif" "stop") + 'words) + 'sieve-control-commands) + ;; action commands + (cons (regexp-opt '("fileinto" "redirect" "reject" "keep" "discard") + 'words) + 'sieve-action-commands) + ;; test commands + (cons (regexp-opt '("address" "allof" "anyof" "exists" "false" + "true" "header" "not" "size" "envelope" + "body") + 'words) + 'sieve-test-commands) + (cons "\\Sw+:\\sw+" + 'sieve-tagged-arguments)))) + +;; Syntax table + +(defvar sieve-mode-syntax-table + (let ((st (make-syntax-table))) + (modify-syntax-entry ?\\ "\\" st) + (modify-syntax-entry ?\n "> " st) + (modify-syntax-entry ?\f "> " st) + (modify-syntax-entry ?\# "< " st) + (modify-syntax-entry ?/ ". 14" st) + (modify-syntax-entry ?* ". 23b" st) + (modify-syntax-entry ?+ "." st) + (modify-syntax-entry ?- "." st) + (modify-syntax-entry ?= "." st) + (modify-syntax-entry ?% "." st) + (modify-syntax-entry ?< "." st) + (modify-syntax-entry ?> "." st) + (modify-syntax-entry ?& "." st) + (modify-syntax-entry ?| "." st) + (modify-syntax-entry ?_ "_" st) + (modify-syntax-entry ?\' "\"" st) + st) + "Syntax table in use in sieve-mode buffers.") + + +;; Key map definition + +(defvar sieve-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-c\C-l" 'sieve-upload) + (define-key map "\C-c\C-c" 'sieve-upload-and-kill) + (define-key map "\C-c\C-m" 'sieve-manage) + map) + "Key map used in sieve mode.") + +;; Menu + +(easy-menu-define sieve-mode-menu sieve-mode-map + "Sieve Menu." + '("Sieve" + ["Upload script" sieve-upload t] + ["Manage scripts on server" sieve-manage t])) + +;; Code for Sieve editing mode. + + +(defun sieve-syntax-propertize (beg end) + (goto-char beg) + (sieve-syntax-propertize-text end) + (funcall + (syntax-propertize-rules + ;; FIXME: When there's a "text:" with a # comment, the \n plays dual role: + ;; it closes the comment and starts the string. This is problematic for us + ;; since syntax-table entries can either close a comment or + ;; delimit a string, but not both. + ("\\_") + (2 (prog1 (unless (save-excursion + (nth 8 (syntax-ppss (match-beginning 0)))) + (string-to-syntax "|")) + (sieve-syntax-propertize-text end))))) + beg end)) + +(defun sieve-syntax-propertize-text (end) + (let ((ppss (syntax-ppss))) + (when (and (eq t (nth 3 ppss)) + (re-search-forward "^\\.\\(\n\\)" end 'move)) + (put-text-property (match-beginning 1) (match-end 1) + 'syntax-table (string-to-syntax "|"))))) + +;;;###autoload +(define-derived-mode sieve-mode c-mode "Sieve" + "Major mode for editing Sieve code. +This is much like C mode except for the syntax of comments. Its keymap +inherits from C mode's and it has the same variables for customizing +indentation. It has its own abbrev table and its own syntax table. + +Turning on Sieve mode runs `sieve-mode-hook'." + (set (make-local-variable 'paragraph-start) (concat "$\\|" page-delimiter)) + (set (make-local-variable 'paragraph-separate) paragraph-start) + (set (make-local-variable 'comment-start) "#") + (set (make-local-variable 'comment-end) "") + ;;(set (make-local-variable 'comment-start-skip) "\\(^\\|\\s-\\);?#+ *") + (set (make-local-variable 'comment-start-skip) "#+ *") + (set (make-local-variable 'syntax-propertize-function) + #'sieve-syntax-propertize) + (set (make-local-variable 'font-lock-defaults) + '(sieve-font-lock-keywords nil nil ((?_ . "w")))) + (easy-menu-add-item nil nil sieve-mode-menu)) + +(provide 'sieve-mode) + +;; sieve-mode.el ends here diff --cc lisp/net/sieve.el index d126d84c5de,00000000000..665a0a8e15d mode 100644,000000..100644 --- a/lisp/net/sieve.el +++ b/lisp/net/sieve.el @@@ -1,373 -1,0 +1,373 @@@ +;;; sieve.el --- Utilities to manage sieve scripts + - ;; Copyright (C) 2001-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2001-2017 Free Software Foundation, Inc. + +;; Author: Simon Josefsson + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This file contain utilities to facilitate upload, download and +;; general management of sieve scripts. Currently only the +;; Managesieve protocol is supported (using sieve-manage.el), but when +;; (useful) alternatives become available, they might be supported as +;; well. +;; +;; The cursor navigation was inspired by biff-mode by Franklin Lee. +;; +;; Release history: +;; +;; 2001-10-31 Committed to Oort Gnus. +;; 2002-07-27 Fix down-mouse-2 and down-mouse-3 in manage-mode. Fix menubar +;; in manage-mode. Change some messages. Added sieve-deactivate*, +;; sieve-remove. Fixed help text in manage-mode. Suggested by +;; Ned Ludd. +;; +;; Todo: +;; +;; * Namespace? This file contains `sieve-manage' and +;; `sieve-manage-mode', but there is a sieve-manage.el file as well. +;; Can't think of a good solution though, this file need a *-mode, +;; and naming it `sieve-mode' would collide with sieve-mode.el. One +;; solution would be to come up with some better name that this file +;; can use that doesn't have the managesieve specific "manage" in +;; it. sieve-dired? i dunno. we could copy all off sieve.el into +;; sieve-manage.el too, but I'd like to separate the interface from +;; the protocol implementation since the backends are likely to +;; change (well). +;; +;; * Define servers? We could have a customize buffer to create a server, +;; with authentication/stream/etc parameters, much like Gnus, and then +;; only use names of defined servers when interacting with M-x sieve-*. +;; Right now you can't use STARTTLS, which sieve-manage.el provides + +;;; Code: + +(require 'sieve-manage) +(require 'sieve-mode) + +;; User customizable variables: + +(defgroup sieve nil + "Manage sieve scripts." + :version "22.1" + :group 'tools) + +(defcustom sieve-new-script "" + "Name of name script indicator." + :type 'string + :group 'sieve) + +(defcustom sieve-buffer "*sieve*" + "Name of sieve management buffer." + :type 'string + :group 'sieve) + +(defcustom sieve-template "\ +require \"fileinto\"; + +# Example script (remove comment character '#' to make it effective!): +# +# if header :contains \"from\" \"coyote\" { +# discard; +# } elsif header :contains [\"subject\"] [\"$$$\"] { +# discard; +# } else { +# fileinto \"INBOX\"; +# } +" + "Template sieve script." + :type 'string + :group 'sieve) + +;; Internal variables: + +(defvar sieve-manage-buffer nil) +(defvar sieve-buffer-header-end nil) +(defvar sieve-buffer-script-name nil + "The real script name of the buffer.") +(make-local-variable 'sieve-buffer-script-name) + +;; Sieve-manage mode: + +(defvar sieve-manage-mode-map + (let ((map (make-sparse-keymap))) + ;; various + (define-key map "?" 'sieve-help) + (define-key map "h" 'sieve-help) + ;; activating + (define-key map "m" 'sieve-activate) + (define-key map "u" 'sieve-deactivate) + (define-key map "\M-\C-?" 'sieve-deactivate-all) + ;; navigation keys + (define-key map "\C-p" 'sieve-prev-line) + (define-key map [up] 'sieve-prev-line) + (define-key map "\C-n" 'sieve-next-line) + (define-key map [down] 'sieve-next-line) + (define-key map " " 'sieve-next-line) + (define-key map "n" 'sieve-next-line) + (define-key map "p" 'sieve-prev-line) + (define-key map "\C-m" 'sieve-edit-script) + (define-key map "f" 'sieve-edit-script) + (define-key map "o" 'sieve-edit-script-other-window) + (define-key map "r" 'sieve-remove) + (define-key map "q" 'sieve-bury-buffer) + (define-key map "Q" 'sieve-manage-quit) + (define-key map [(down-mouse-2)] 'sieve-edit-script) + (define-key map [(down-mouse-3)] 'sieve-manage-mode-menu) + map) + "Keymap for `sieve-manage-mode'.") + +(easy-menu-define sieve-manage-mode-menu sieve-manage-mode-map + "Sieve Menu." + '("Manage Sieve" + ["Edit script" sieve-edit-script t] + ["Activate script" sieve-activate t] + ["Deactivate script" sieve-deactivate t])) + +(define-derived-mode sieve-manage-mode fundamental-mode "Sieve-manage" + "Mode used for sieve script management." + (buffer-disable-undo (current-buffer)) + (setq truncate-lines t) + (easy-menu-add sieve-manage-mode-menu sieve-manage-mode-map)) + +(put 'sieve-manage-mode 'mode-class 'special) + +;; Commands used in sieve-manage mode: + +(defun sieve-manage-quit () + "Quit Manage Sieve and close the connection." + (interactive) + (sieve-manage-close sieve-manage-buffer) + (kill-buffer sieve-manage-buffer) + (kill-buffer (current-buffer))) + +(defun sieve-bury-buffer () + "Bury the Manage Sieve buffer without closing the connection." + (interactive) + (bury-buffer)) + +(defun sieve-activate (&optional pos) + (interactive "d") + (let ((name (sieve-script-at-point)) err) + (when (or (null name) (string-equal name sieve-new-script)) + (error "No sieve script at point")) + (message "Activating script %s..." name) + (setq err (sieve-manage-setactive name sieve-manage-buffer)) + (sieve-refresh-scriptlist) + (if (sieve-manage-ok-p err) + (message "Activating script %s...done" name) + (message "Activating script %s...failed: %s" name (nth 2 err))))) + +(defun sieve-deactivate-all (&optional pos) + (interactive "d") + (let ((name (sieve-script-at-point)) err) + (message "Deactivating scripts...") + (setq err (sieve-manage-setactive "" sieve-manage-buffer)) + (sieve-refresh-scriptlist) + (if (sieve-manage-ok-p err) + (message "Deactivating scripts...done") + (message "Deactivating scripts...failed: %s" (nth 2 err))))) + +(defalias 'sieve-deactivate 'sieve-deactivate-all) + +(defun sieve-remove (&optional pos) + (interactive "d") + (let ((name (sieve-script-at-point)) err) + (when (or (null name) (string-equal name sieve-new-script)) + (error "No sieve script at point")) + (message "Removing sieve script %s..." name) + (setq err (sieve-manage-deletescript name sieve-manage-buffer)) + (unless (sieve-manage-ok-p err) + (error "Removing sieve script %s...failed: " err)) + (sieve-refresh-scriptlist) + (message "Removing sieve script %s...done" name))) + +(defun sieve-edit-script (&optional pos) + (interactive "d") + (let ((name (sieve-script-at-point))) + (unless name + (error "No sieve script at point")) + (if (not (string-equal name sieve-new-script)) + (let ((newbuf (generate-new-buffer name)) + err) + (setq err (sieve-manage-getscript name newbuf sieve-manage-buffer)) + (switch-to-buffer newbuf) + (if (sieve-manage-ok-p err) + (set-buffer-modified-p nil) + (error "Sieve download failed: %s" err))) + (switch-to-buffer (get-buffer-create "template.siv")) + (insert sieve-template)) + (sieve-mode) + (setq sieve-buffer-script-name name) + (goto-char (point-min)) + (message + (substitute-command-keys + "Press \\[sieve-upload] to upload script to server.")))) + +(defmacro sieve-change-region (&rest body) + "Turns off sieve-region before executing BODY, then re-enables it after. +Used to bracket operations which move point in the sieve-buffer." + `(progn + (sieve-highlight nil) + ,@body + (sieve-highlight t))) +(put 'sieve-change-region 'lisp-indent-function 0) + +(defun sieve-next-line (&optional arg) + (interactive) + (unless arg + (setq arg 1)) + (if (save-excursion + (forward-line arg) + (sieve-script-at-point)) + (sieve-change-region + (forward-line arg)) + (message "End of list"))) + +(defun sieve-prev-line (&optional arg) + (interactive) + (unless arg + (setq arg -1)) + (if (save-excursion + (forward-line arg) + (sieve-script-at-point)) + (sieve-change-region + (forward-line arg)) + (message "Beginning of list"))) + +(defun sieve-help () + "Display help for various sieve commands." + (interactive) + (if (eq last-command 'sieve-help) + ;; would need minor-mode for log-edit-mode + (describe-function 'sieve-mode) + (message "%s" (substitute-command-keys + "`\\[sieve-edit-script]':edit `\\[sieve-activate]':activate `\\[sieve-deactivate]':deactivate `\\[sieve-remove]':remove")))) + +;; Create buffer: + +(defun sieve-setup-buffer (server port) + (setq buffer-read-only nil) + (erase-buffer) + (buffer-disable-undo) + (let* ((port (or port sieve-manage-default-port)) + (header (format "Server : %s:%s\n\n" server port))) + (insert header)) + (set (make-local-variable 'sieve-buffer-header-end) + (point-max))) + +(defun sieve-script-at-point (&optional pos) + "Return name of sieve script at point POS, or nil." + (interactive "d") + (get-char-property (or pos (point)) 'script-name)) + +(defun sieve-highlight (on) + "Turn ON or off highlighting on the current language overlay." + (overlay-put (car (overlays-at (point))) 'face (if on 'highlight 'default))) + +(defun sieve-insert-scripts (scripts) + "Format and insert LANGUAGE-LIST strings into current buffer at point." + (while scripts + (let ((p (point)) + (ext nil) + (script (pop scripts))) + (if (consp script) + (insert (format " ACTIVE %s" (cdr script))) + (insert (format " %s" script))) + (setq ext (make-overlay p (point))) + (overlay-put ext 'mouse-face 'highlight) + (overlay-put ext 'script-name (if (consp script) + (cdr script) + script)) + (insert "\n")))) + +(defun sieve-open-server (server &optional port) + "Open SERVER (on PORT) and authenticate." + (with-current-buffer + (or ;; open server + (set (make-local-variable 'sieve-manage-buffer) + (sieve-manage-open server port)) + (error "Error opening server %s" server)) + (sieve-manage-authenticate))) + +(defun sieve-refresh-scriptlist () + (interactive) + (with-current-buffer sieve-buffer + (setq buffer-read-only nil) + (delete-region (or sieve-buffer-header-end (point-max)) (point-max)) + (goto-char (point-max)) + ;; get list of script names and print them + (let ((scripts (sieve-manage-listscripts sieve-manage-buffer))) + (if (null scripts) + (insert + (substitute-command-keys + (format + "No scripts on server, press \\[sieve-edit-script] on %s to create a new script.\n" + sieve-new-script))) + (insert + (substitute-command-keys + (format (concat "%d script%s on server, press \\[sieve-edit-script] on a script " + "name edits it, or\npress \\[sieve-edit-script] on %s to create " + "a new script.\n") (length scripts) + (if (eq (length scripts) 1) "" "s") + sieve-new-script)))) + (save-excursion + (sieve-insert-scripts (list sieve-new-script)) + (sieve-insert-scripts scripts))) + (sieve-highlight t) + (setq buffer-read-only t))) + +;;;###autoload +(defun sieve-manage (server &optional port) + (interactive "sServer: ") + (switch-to-buffer (get-buffer-create sieve-buffer)) + (sieve-manage-mode) + (sieve-setup-buffer server port) + (if (sieve-open-server server port) + (sieve-refresh-scriptlist) + (message "Could not open server %s" server))) + +;;;###autoload +(defun sieve-upload (&optional name) + (interactive) + (when (or (get-buffer sieve-buffer) (call-interactively 'sieve-manage)) + (let ((script (buffer-string)) err) + (with-current-buffer (get-buffer sieve-buffer) + (setq err (sieve-manage-putscript + (or name sieve-buffer-script-name (buffer-name)) + script sieve-manage-buffer)) + (if (sieve-manage-ok-p err) + (message (substitute-command-keys + "Sieve upload done. Use \\[sieve-manage] to manage scripts.")) + (message "Sieve upload failed: %s" (nth 2 err))))))) + +;;;###autoload +(defun sieve-upload-and-bury (&optional name) + (interactive) + (sieve-upload name) + (bury-buffer)) + +;;;###autoload +(defun sieve-upload-and-kill (&optional name) + (interactive) + (sieve-upload name) + (kill-buffer)) + +(provide 'sieve) + +;; sieve.el ends here diff --cc lisp/net/starttls.el index b9255901f97,00000000000..4de3d69e4f8 mode 100644,000000..100644 --- a/lisp/net/starttls.el +++ b/lisp/net/starttls.el @@@ -1,304 -1,0 +1,304 @@@ +;;; starttls.el --- STARTTLS functions + - ;; Copyright (C) 1999-2016 Free Software Foundation, Inc. ++;; Copyright (C) 1999-2017 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Author: Simon Josefsson +;; Created: 1999/11/20 +;; Keywords: TLS, SSL, OpenSSL, GnuTLS, mail, news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This module defines some utility functions for STARTTLS profiles. + +;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP" +;; by Chris Newman (1999/06) + +;; This file now contains a combination of the two previous +;; implementations both called "starttls.el". The first one is Daiki +;; Ueno's starttls.el which uses his own "starttls" command line tool, +;; and the second one is Simon Josefsson's starttls.el which uses +;; "gnutls-cli" from GnuTLS. +;; +;; If "starttls" is available, it is preferred by the code over +;; "gnutls-cli", for backwards compatibility. Use +;; `starttls-use-gnutls' to toggle between implementations if you have +;; both tools installed. It is recommended to use GnuTLS, though, as +;; it performs more verification of the certificates. + +;; The GnuTLS support requires GnuTLS 0.9.90 (released 2003-10-08) or +;; later, from , or "starttls" +;; from . + +;; Usage is similar to `open-network-stream'. For example: +;; +;; (when (setq tmp (starttls-open-stream +;; "test" (current-buffer) "yxa.extundo.com" 25)) +;; (accept-process-output tmp 15) +;; (process-send-string tmp "STARTTLS\n") +;; (accept-process-output tmp 15) +;; (message "STARTTLS output:\n%s" (starttls-negotiate tmp)) +;; (process-send-string tmp "EHLO foo\n")) + +;; An example run yields the following output: +;; +;; 220 yxa.extundo.com ESMTP Sendmail 8.12.11/8.12.11/Debian-3; Wed, 26 May 2004 19:12:29 +0200; (No UCE/UBE) logging access from: c494102a.s-bi.bostream.se(OK)-c494102a.s-bi.bostream.se [217.215.27.65] +;; 220 2.0.0 Ready to start TLS +;; 250-yxa.extundo.com Hello c494102a.s-bi.bostream.se [217.215.27.65], pleased to meet you +;; 250-ENHANCEDSTATUSCODES +;; 250-PIPELINING +;; 250-EXPN +;; 250-VERB +;; 250-8BITMIME +;; 250-SIZE +;; 250-DSN +;; 250-ETRN +;; 250-AUTH DIGEST-MD5 CRAM-MD5 PLAIN LOGIN +;; 250-DELIVERBY +;; 250 HELP +;; nil +;; +;; With the message buffer containing: +;; +;; STARTTLS output: +;; *** Starting TLS handshake +;; - Server's trusted authorities: +;; [0]: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com +;; - Certificate type: X.509 +;; - Got a certificate list of 2 certificates. +;; +;; - Certificate[0] info: +;; # The hostname in the certificate matches 'yxa.extundo.com'. +;; # valid since: Wed May 26 12:16:00 CEST 2004 +;; # expires at: Wed Jul 26 12:16:00 CEST 2023 +;; # serial number: 04 +;; # fingerprint: 7c 04 4b c1 fa 26 9b 5d 90 22 52 3c 65 3d 85 3a +;; # version: #1 +;; # public key algorithm: RSA +;; # Modulus: 1024 bits +;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=Mail server,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com +;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com +;; +;; - Certificate[1] info: +;; # valid since: Sun May 23 11:35:00 CEST 2004 +;; # expires at: Sun Jul 23 11:35:00 CEST 2023 +;; # serial number: 00 +;; # fingerprint: fc 76 d8 63 1a c9 0b 3b fa 40 fe ed 47 7a 58 ae +;; # version: #3 +;; # public key algorithm: RSA +;; # Modulus: 1024 bits +;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com +;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com +;; +;; - Peer's certificate issuer is unknown +;; - Peer's certificate is NOT trusted +;; - Version: TLS 1.0 +;; - Key Exchange: RSA +;; - Cipher: ARCFOUR 128 +;; - MAC: SHA +;; - Compression: NULL + +;;; Code: + +(defgroup starttls nil + "Support for `Transport Layer Security' protocol." + :version "21.1" + :group 'mail) + +(defcustom starttls-gnutls-program "gnutls-cli" + "Name of GnuTLS command line tool. +This program is used when GnuTLS is used, i.e. when +`starttls-use-gnutls' is non-nil." + :version "22.1" + :type 'string + :group 'starttls) + +(defcustom starttls-program "starttls" + "The program to run in a subprocess to open an TLSv1 connection. +This program is used when the `starttls' command is used, +i.e. when `starttls-use-gnutls' is nil." + :type 'string + :group 'starttls) + +(defcustom starttls-use-gnutls (not (executable-find starttls-program)) + "Whether to use GnuTLS instead of the `starttls' command." + :version "22.1" + :type 'boolean + :group 'starttls) + +(defcustom starttls-extra-args nil + "Extra arguments to `starttls-program'. +These apply when the `starttls' command is used, i.e. when +`starttls-use-gnutls' is nil." + :type '(repeat string) + :group 'starttls) + +(defcustom starttls-extra-arguments nil + "Extra arguments to `starttls-gnutls-program'. +These apply when GnuTLS is used, i.e. when `starttls-use-gnutls' is non-nil. + +For example, non-TLS compliant servers may require +\(\"--protocols\" \"ssl3\"). Invoke \"gnutls-cli --help\" to +find out which parameters are available." + :version "22.1" + :type '(repeat string) + :group 'starttls) + +(defcustom starttls-process-connection-type nil + "Value for `process-connection-type' to use when starting STARTTLS process." + :version "22.1" + :type 'boolean + :group 'starttls) + +(defcustom starttls-connect "- Simple Client Mode:\n\n" + "Regular expression indicating successful connection. +The default is what GnuTLS's \"gnutls-cli\" outputs." + ;; GnuTLS cli.c:main() prints this string when it is starting to run + ;; in the application read/write phase. If the logic, or the string + ;; itself, is modified, this must be updated. + :version "22.1" + :type 'regexp + :group 'starttls) + +(defcustom starttls-failure "\\*\\*\\* Handshake has failed" + "Regular expression indicating failed TLS handshake. +The default is what GnuTLS's \"gnutls-cli\" outputs." + ;; GnuTLS cli.c:do_handshake() prints this string on failure. If the + ;; logic, or the string itself, is modified, this must be updated. + :version "22.1" + :type 'regexp + :group 'starttls) + +(defcustom starttls-success "- Compression: " + "Regular expression indicating completed TLS handshakes. +The default is what GnuTLS's \"gnutls-cli\" outputs." + ;; GnuTLS cli.c:do_handshake() calls, on success, + ;; common.c:print_info(), that unconditionally print this string + ;; last. If that logic, or the string itself, is modified, this + ;; must be updated. + :version "22.1" + :type 'regexp + :group 'starttls) + +(defun starttls-negotiate-gnutls (process) + "Negotiate TLS on PROCESS opened by `open-starttls-stream'. +This should typically only be done once. It typically returns a +multi-line informational message with information about the +handshake, or nil on failure." + (let (buffer info old-max done-ok done-bad) + (if (null (setq buffer (process-buffer process))) + ;; XXX How to remove/extract the TLS negotiation junk? + (signal-process (process-id process) 'SIGALRM) + (with-current-buffer buffer + (save-excursion + (setq old-max (goto-char (point-max))) + (signal-process (process-id process) 'SIGALRM) + (while (and (processp process) + (eq (process-status process) 'run) + (save-excursion + (goto-char old-max) + (not (or (setq done-ok (re-search-forward + starttls-success nil t)) + (setq done-bad (re-search-forward + starttls-failure nil t)))))) + (accept-process-output process 1 100) + (sit-for 0.1)) + (setq info (buffer-substring-no-properties old-max (point-max))) + (delete-region old-max (point-max)) + (if (or (and done-ok (not done-bad)) + ;; Prevent mitm that fake success msg after failure msg. + (and done-ok done-bad (< done-ok done-bad))) + info + (message "STARTTLS negotiation failed: %s" info) + nil)))))) + +(defun starttls-negotiate (process) + (if starttls-use-gnutls + (starttls-negotiate-gnutls process) + (signal-process (process-id process) 'SIGALRM))) + +(defun starttls-open-stream-gnutls (name buffer host port) + (message "Opening STARTTLS connection to `%s:%s'..." host port) + (let* (done + (old-max (with-current-buffer buffer (point-max))) + (process-connection-type starttls-process-connection-type) + (process (apply #'start-process name buffer + starttls-gnutls-program "-s" host + "-p" (if (integerp port) + (int-to-string port) + port) + starttls-extra-arguments))) + (set-process-query-on-exit-flag process nil) + (while (and (processp process) + (eq (process-status process) 'run) + (with-current-buffer buffer + (goto-char old-max) + (not (setq done (re-search-forward + starttls-connect nil t))))) + (accept-process-output process 0 100) + (sit-for 0.1)) + (if done + (with-current-buffer buffer + (delete-region old-max done)) + (delete-process process) + (setq process nil)) + (message "Opening STARTTLS connection to `%s:%s'...%s" + host port (if done "done" "failed")) + process)) + +;;;###autoload +(defun starttls-open-stream (name buffer host port) + "Open a TLS connection for a port to a host. +Returns a subprocess object to represent the connection. +Input and output work as for subprocesses; `delete-process' closes it. +Args are NAME BUFFER HOST PORT. +NAME is name for process. It is modified if necessary to make it unique. +BUFFER is the buffer (or `buffer-name') to associate with the process. + Process output goes at end of that buffer, unless you specify + an output stream or filter function to handle the output. + BUFFER may be also nil, meaning that this process is not associated + with any buffer +Third arg is name of the host to connect to, or its IP address. +Fourth arg PORT is an integer specifying a port to connect to. +If `starttls-use-gnutls' is nil, this may also be a service name, but +GnuTLS requires a port number." + (if starttls-use-gnutls + (starttls-open-stream-gnutls name buffer host port) + (message "Opening STARTTLS connection to `%s:%s'" host (format "%s" port)) + (let* ((process-connection-type starttls-process-connection-type) + (process (apply #'start-process + name buffer starttls-program + host (format "%s" port) + starttls-extra-args))) + (set-process-query-on-exit-flag process nil) + process))) + +(defun starttls-available-p () + "Say whether the STARTTLS programs are available." + (and (not (memq system-type '(windows-nt ms-dos))) + (executable-find (if starttls-use-gnutls + starttls-gnutls-program + starttls-program)))) + +(defalias 'starttls-any-program-available 'starttls-available-p) +(make-obsolete 'starttls-any-program-available 'starttls-available-p + "2011-08-02") + +(provide 'starttls) + +;;; starttls.el ends here diff --cc lisp/nxml/nxml-enc.el index 6406f57ff63,0c45a6600ba..b359076ef4d --- a/lisp/nxml/nxml-enc.el +++ b/lisp/nxml/nxml-enc.el @@@ -1,6 -1,6 +1,6 @@@ -;;; nxml-enc.el --- XML encoding auto-detection +;;; nxml-enc.el --- XML encoding auto-detection -*- lexical-binding:t -*- - ;; Copyright (C) 2003, 2007-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2003, 2007-2017 Free Software Foundation, Inc. ;; Author: James Clark ;; Keywords: wp, hypermedia, languages, XML diff --cc lisp/nxml/nxml-maint.el index 5d24d9b3138,ed077764806..55abca18e05 --- a/lisp/nxml/nxml-maint.el +++ b/lisp/nxml/nxml-maint.el @@@ -1,6 -1,6 +1,6 @@@ -;;; nxml-maint.el --- commands for maintainers of nxml-*.el +;;; nxml-maint.el --- commands for maintainers of nxml-*.el -*- lexical-binding:t -*- - ;; Copyright (C) 2003, 2007-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2003, 2007-2017 Free Software Foundation, Inc. ;; Author: James Clark ;; Keywords: wp, hypermedia, languages, XML diff --cc lisp/nxml/nxml-outln.el index 289816a1bba,91a3273e96e..2c414e489da --- a/lisp/nxml/nxml-outln.el +++ b/lisp/nxml/nxml-outln.el @@@ -1,6 -1,6 +1,6 @@@ -;;; nxml-outln.el --- outline support for nXML mode +;;; nxml-outln.el --- outline support for nXML mode -*- lexical-binding:t -*- - ;; Copyright (C) 2004, 2007-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2004, 2007-2017 Free Software Foundation, Inc. ;; Author: James Clark ;; Keywords: wp, hypermedia, languages, XML diff --cc lisp/nxml/nxml-parse.el index edf012921a9,dda56b02705..bce8cc9ee0b --- a/lisp/nxml/nxml-parse.el +++ b/lisp/nxml/nxml-parse.el @@@ -1,6 -1,6 +1,6 @@@ -;;; nxml-parse.el --- XML parser, sharing infrastructure with nxml-mode +;;; nxml-parse.el --- XML parser, sharing infrastructure with nxml-mode -*- lexical-binding:t -*- - ;; Copyright (C) 2003, 2007-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2003, 2007-2017 Free Software Foundation, Inc. ;; Author: James Clark ;; Keywords: wp, hypermedia, languages, XML diff --cc lisp/nxml/nxml-rap.el index e66289d042a,609dfe732a1..0132a2b9234 --- a/lisp/nxml/nxml-rap.el +++ b/lisp/nxml/nxml-rap.el @@@ -1,6 -1,6 +1,6 @@@ -;;; nxml-rap.el --- low-level support for random access parsing for nXML mode +;;; nxml-rap.el --- low-level support for random access parsing for nXML mode -*- lexical-binding:t -*- - ;; Copyright (C) 2003-2004, 2007-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2003-2004, 2007-2017 Free Software Foundation, Inc. ;; Author: James Clark ;; Keywords: wp, hypermedia, languages, XML diff --cc lisp/nxml/rng-cmpct.el index ed88dfa98e9,e008ce9abc4..a09c77c51ae --- a/lisp/nxml/rng-cmpct.el +++ b/lisp/nxml/rng-cmpct.el @@@ -1,6 -1,6 +1,6 @@@ -;;; rng-cmpct.el --- parsing of RELAX NG Compact Syntax schemas +;;; rng-cmpct.el --- parsing of RELAX NG Compact Syntax schemas -*- lexical-binding:t -*- - ;; Copyright (C) 2003, 2007-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2003, 2007-2017 Free Software Foundation, Inc. ;; Author: James Clark ;; Keywords: wp, hypermedia, languages, XML, RelaxNG diff --cc lisp/nxml/rng-dt.el index a3cb8bc6aa5,63b7013a303..6e60609445e --- a/lisp/nxml/rng-dt.el +++ b/lisp/nxml/rng-dt.el @@@ -1,6 -1,6 +1,6 @@@ -;;; rng-dt.el --- datatype library interface for RELAX NG +;;; rng-dt.el --- datatype library interface for RELAX NG -*- lexical-binding:t -*- - ;; Copyright (C) 2003, 2007-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2003, 2007-2017 Free Software Foundation, Inc. ;; Author: James Clark ;; Keywords: wp, hypermedia, languages, XML, RelaxNG diff --cc lisp/nxml/rng-loc.el index 376e9169d37,705db170d66..359a7178684 --- a/lisp/nxml/rng-loc.el +++ b/lisp/nxml/rng-loc.el @@@ -1,6 -1,6 +1,6 @@@ -;;; rng-loc.el --- locate the schema to use for validation +;;; rng-loc.el --- Locate the schema to use for validation -*- lexical-binding:t -*- - ;; Copyright (C) 2003, 2007-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2003, 2007-2017 Free Software Foundation, Inc. ;; Author: James Clark ;; Keywords: wp, hypermedia, languages, XML, RelaxNG diff --cc lisp/nxml/rng-maint.el index 32a041e0c17,e54325c4f19..8378b1d6491 --- a/lisp/nxml/rng-maint.el +++ b/lisp/nxml/rng-maint.el @@@ -1,6 -1,6 +1,6 @@@ -;;; rng-maint.el --- commands for RELAX NG maintainers +;;; rng-maint.el --- commands for RELAX NG maintainers -*- lexical-binding:t -*- - ;; Copyright (C) 2003, 2007-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2003, 2007-2017 Free Software Foundation, Inc. ;; Author: James Clark ;; Keywords: wp, hypermedia, languages, XML, RelaxNG diff --cc lisp/nxml/rng-nxml.el index 954a1eb9599,f014da7fb19..caa3d63e390 --- a/lisp/nxml/rng-nxml.el +++ b/lisp/nxml/rng-nxml.el @@@ -1,6 -1,6 +1,6 @@@ -;;; rng-nxml.el --- make nxml-mode take advantage of rng-validate-mode +;;; rng-nxml.el --- make nxml-mode take advantage of rng-validate-mode -*- lexical-binding:t -*- - ;; Copyright (C) 2003, 2007-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2003, 2007-2017 Free Software Foundation, Inc. ;; Author: James Clark ;; Keywords: wp, hypermedia, languages, XML, RelaxNG diff --cc lisp/nxml/rng-parse.el index 3ae4b5cc9c4,afa693ebcae..f3afbdd07de --- a/lisp/nxml/rng-parse.el +++ b/lisp/nxml/rng-parse.el @@@ -1,6 -1,6 +1,6 @@@ -;;; rng-parse.el --- parse an XML file and validate it against a schema +;;; rng-parse.el --- parse an XML file and validate it against a schema -*- lexical-binding:t -*- - ;; Copyright (C) 2003, 2007-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2003, 2007-2017 Free Software Foundation, Inc. ;; Author: James Clark ;; Keywords: wp, hypermedia, languages, XML, RelaxNG diff --cc lisp/nxml/rng-pttrn.el index e847f5e02a8,a974994e185..29b55816a79 --- a/lisp/nxml/rng-pttrn.el +++ b/lisp/nxml/rng-pttrn.el @@@ -1,6 -1,6 +1,6 @@@ -;;; rng-pttrn.el --- RELAX NG patterns +;;; rng-pttrn.el --- RELAX NG patterns -*- lexical-binding:t -*- - ;; Copyright (C) 2003, 2007-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2003, 2007-2017 Free Software Foundation, Inc. ;; Author: James Clark ;; Keywords: wp, hypermedia, languages, XML, RelaxNG diff --cc lisp/nxml/rng-uri.el index 8fc0a01e293,dc4e9513944..6b3190a1b09 --- a/lisp/nxml/rng-uri.el +++ b/lisp/nxml/rng-uri.el @@@ -1,6 -1,6 +1,6 @@@ -;;; rng-uri.el --- URI parsing and manipulation +;;; rng-uri.el --- URI parsing and manipulation -*- lexical-binding:t -*- - ;; Copyright (C) 2003, 2007-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2003, 2007-2017 Free Software Foundation, Inc. ;; Author: James Clark ;; Keywords: wp, hypermedia, languages, XML diff --cc lisp/nxml/rng-valid.el index 239b1d11db1,b746781096a..6837424857c --- a/lisp/nxml/rng-valid.el +++ b/lisp/nxml/rng-valid.el @@@ -1,6 -1,6 +1,6 @@@ -;;; rng-valid.el --- real-time validation of XML using RELAX NG +;;; rng-valid.el --- real-time validation of XML using RELAX NG -*- lexical-binding:t -*- - ;; Copyright (C) 2003, 2007-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2003, 2007-2017 Free Software Foundation, Inc. ;; Author: James Clark ;; Keywords: wp, hypermedia, languages, XML, RelaxNG diff --cc lisp/nxml/rng-xsd.el index c0989ae1073,bb58a1b58a3..51a05f8cad5 --- a/lisp/nxml/rng-xsd.el +++ b/lisp/nxml/rng-xsd.el @@@ -1,6 -1,6 +1,6 @@@ -;;; rng-xsd.el --- W3C XML Schema datatypes library for RELAX NG +;;; rng-xsd.el --- W3C XML Schema datatypes library for RELAX NG -*- lexical-binding:t -*- - ;; Copyright (C) 2003, 2007-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2003, 2007-2017 Free Software Foundation, Inc. ;; Author: James Clark ;; Keywords: wp, hypermedia, languages, XML, RelaxNG diff --cc lisp/nxml/xsd-regexp.el index a3f476d00be,fbcdacfcff6..6acb1ff9d41 --- a/lisp/nxml/xsd-regexp.el +++ b/lisp/nxml/xsd-regexp.el @@@ -1,6 -1,6 +1,6 @@@ -;;; xsd-regexp.el --- translate W3C XML Schema regexps to Emacs regexps +;;; xsd-regexp.el --- translate W3C XML Schema regexps to Emacs regexps -*- lexical-binding:t -*- - ;; Copyright (C) 2003, 2007-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2003, 2007-2017 Free Software Foundation, Inc. ;; Author: James Clark ;; Keywords: wp, hypermedia, languages, XML, regexp diff --cc lisp/obsolete/gs.el index c4cdcebff8e,00000000000..5bc77d8c349 mode 100644,000000..100644 --- a/lisp/obsolete/gs.el +++ b/lisp/obsolete/gs.el @@@ -1,226 -1,0 +1,226 @@@ +;;; gs.el --- interface to Ghostscript + - ;; Copyright (C) 1998, 2001-2016 Free Software Foundation, Inc. ++;; Copyright (C) 1998, 2001-2017 Free Software Foundation, Inc. + +;; Maintainer: emacs-devel@gnu.org +;; Keywords: internal +;; Obsolete-since: 26.1 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This code is experimental. Don't use it. Try imagemagick images instead. +;; When this file is removed from Emacs, associated code in image.c +;; can be removed too (HAVE_GHOSTSCRIPT). + +;;; Code: + +(defvar gs-program "gs" + "The name of the Ghostscript interpreter.") + + +(defvar gs-device "x11" + "The Ghostscript device to use to produce images.") + + +(defvar gs-options + '("-q" + ;"-dNOPAUSE" + "-dSAFER" + "-dBATCH" + "-sDEVICE=" + "") + "List of command line arguments to pass to Ghostscript. +Arguments may contain place-holders `' for the name of the +input file, and `' for the device to use.") +(put 'gs-options 'risky-local-variable t) + +(defun gs-options (device file) + "Return a list of command line options with place-holders replaced. +DEVICE is the value to substitute for the place-holder `', +FILE is the value to substitute for the place-holder `'." + (mapcar #'(lambda (option) + (setq option (replace-regexp-in-string "" device option) + option (replace-regexp-in-string "" file option))) + gs-options)) + +;; The GHOSTVIEW property (taken from gv 3.5.8). +;; +;; Type: +;; +;; STRING +;; +;; Parameters: +;; +;; BPIXMAP ORIENT LLX LLY URX URY XDPI YDPI [LEFT BOTTOM TOP RIGHT] +;; +;; Scanf format: "%d %d %d %d %d %d %f %f %d %d %d %d" +;; +;; Explanation of parameters: +;; +;; BPIXMAP: pixmap id of the backing pixmap for the window. If no +;; pixmap is to be used, this parameter should be zero. This +;; parameter must be zero when drawing on a pixmap. +;; +;; ORIENT: orientation of the page. The number represents clockwise +;; rotation of the paper in degrees. Permitted values are 0, 90, 180, +;; 270. +;; +;; LLX, LLY, URX, URY: Bounding box of the drawable. The bounding box +;; is specified in PostScript points in default user coordinates. +;; +;; XDPI, YDPI: Resolution of window. (This can be derived from the +;; other parameters, but not without roundoff error. These values are +;; included to avoid this error.) +;; +;; LEFT, BOTTOM, TOP, RIGHT: (optional) Margins around the window. +;; The margins extend the imageable area beyond the boundaries of the +;; window. This is primarily used for popup zoom windows. I have +;; encountered several instances of PostScript programs that position +;; themselves with respect to the imageable area. The margins are +;; specified in PostScript points. If omitted, the margins are +;; assumed to be 0. + +(declare-function x-display-mm-width "xfns.c" (&optional terminal)) +(declare-function x-display-pixel-width "xfns.c" (&optional terminal)) + +(defun gs-width-in-pt (frame pixel-width) + "Return, on FRAME, pixel width PIXEL-WIDTH translated to pt." + (let ((mm (* (float pixel-width) + (/ (float (x-display-mm-width frame)) + (float (x-display-pixel-width frame)))))) + (/ (* 25.4 mm) 72.0))) + +(declare-function x-display-mm-height "xfns.c" (&optional terminal)) +(declare-function x-display-pixel-height "xfns.c" (&optional terminal)) + +(defun gs-height-in-pt (frame pixel-height) + "Return, on FRAME, pixel height PIXEL-HEIGHT translated to pt." + (let ((mm (* (float pixel-height) + (/ (float (x-display-mm-height frame)) + (float (x-display-pixel-height frame)))))) + (/ (* 25.4 mm) 72.0))) + +(declare-function x-change-window-property "xfns.c" + (prop value &optional frame type format outer-p)) + +(defun gs-set-ghostview-window-prop (frame spec img-width img-height) + "Set the `GHOSTVIEW' window property of FRAME. +SPEC is a GS image specification. IMG-WIDTH is the width of the +requested image, and IMG-HEIGHT is the height of the requested +image in pixels." + (let* ((box (plist-get (cdr spec) :bounding-box)) + (llx (elt box 0)) + (lly (elt box 1)) + (urx (elt box 2)) + (ury (elt box 3)) + (rotation (or (plist-get (cdr spec) :rotate) 0)) + ;; The pixel width IMG-WIDTH of the pixmap gives the + ;; dots, URX - LLX give the inch. + (in-width (/ (- urx llx) 72.0)) + (in-height (/ (- ury lly) 72.0)) + (xdpi (/ img-width in-width)) + (ydpi (/ img-height in-height))) + (x-change-window-property "GHOSTVIEW" + (format "0 %d %d %d %d %d %g %g" + rotation llx lly urx ury xdpi ydpi) + frame))) + +(declare-function x-display-grayscale-p "xfns.c" (&optional terminal)) + +(defun gs-set-ghostview-colors-window-prop (frame pixel-colors) + "Set the `GHOSTVIEW_COLORS' environment variable depending on FRAME." + (let ((mode (cond ((x-display-color-p frame) "Color") + ((x-display-grayscale-p frame) "Grayscale") + (t "Monochrome")))) + (x-change-window-property "GHOSTVIEW_COLORS" + (format "%s %s" mode pixel-colors) + frame))) + +(declare-function x-window-property "xfns.c" + (prop &optional frame type source delete-p vector-ret-p)) + +;;;###autoload +(defun gs-load-image (frame spec img-width img-height window-and-pixmap-id + pixel-colors) + "Load a PS image for display on FRAME. +SPEC is an image specification, IMG-HEIGHT and IMG-WIDTH are width +and height of the image in pixels. WINDOW-AND-PIXMAP-ID is a string of +the form \"WINDOW-ID PIXMAP-ID\". Value is non-nil if successful." + (unwind-protect + (let ((file (plist-get (cdr spec) :file)) + gs + (timeout 40)) + ;; Wait while property gets freed from a previous ghostscript process + ;; sit-for returns nil as soon as input starts being + ;; available, so if we want to give GhostScript a reasonable + ;; chance of starting up, we better use sleep-for. We let + ;; sleep-for wait only half the time because if input is + ;; available, it is more likely that we don't care that much + ;; about garbled redisplay and are in a hurry. + (while (and + ;; Wait while the property is not yet available + (not (zerop (length (x-window-property "GHOSTVIEW" + frame)))) + ;; The following was an alternative condition: wait + ;; while there is still a process running. The idea + ;; was to avoid contention between processes. Turned + ;; out even more sluggish. + ;; (get-buffer-process "*GS*") + (not (zerop timeout))) + (unless (sit-for 0.1 t) + (sleep-for 0.05)) + (setq timeout (1- timeout))) + + ;; No use waiting longer. We might want to try killing off + ;; stuck processes, but there is no point in doing so: either + ;; they are stuck for good, in which case the user would + ;; probably be responsible for that, and killing them off will + ;; make debugging harder, or they are not. In that case, they + ;; will cause incomplete displays. But the same will happen + ;; if they are killed, anyway. The whole is rather + ;; disconcerting, and fast scrolling through a dozen images + ;; will make Emacs freeze for a while. The alternatives are a) + ;; proper implementation not waiting at all but creating + ;; appropriate queues, or b) permanently bad display due to + ;; bad cached images. So remember that this + ;; is just a hack and if people don't like the behavior, they + ;; will most likely like the easy alternatives even less. + ;; And at least the image cache will make the delay apparent + ;; just once. + (gs-set-ghostview-window-prop frame spec img-width img-height) + (gs-set-ghostview-colors-window-prop frame pixel-colors) + (setenv "GHOSTVIEW" window-and-pixmap-id) + (setq gs (apply 'start-process "gs" "*GS*" gs-program + (gs-options gs-device file))) + (set-process-query-on-exit-flag gs nil) + gs) + nil)) + + +;(defun gs-put-tiger () +; (let* ((ps-file "/usr/local/share/ghostscript/5.10/examples/tiger.ps") +; (spec `(image :type postscript +; :pt-width 200 :pt-height 200 +; :bounding-box (22 171 567 738) +; :file ,ps-file))) +; (put-text-property 1 2 'display spec))) +; + +(provide 'gs) + +;;; gs.el ends here diff --cc lisp/obsolete/iso-acc.el index 00000000000,f0a9058a649..a18d4e543f6 mode 000000,100644..100644 --- a/lisp/obsolete/iso-acc.el +++ b/lisp/obsolete/iso-acc.el @@@ -1,0 -1,489 +1,489 @@@ + ;;; iso-acc.el --- minor mode providing electric accent keys + + ;; Copyright (C) 1993-1994, 1996, 2001-2017 Free Software Foundation, + ;; Inc. + + ;; Author: Johan Vromans + ;; Maintainer: emacs-devel@gnu.org + ;; Keywords: i18n + ;; Obsolete-since: 22.1 + + ;; This file is part of GNU Emacs. + + ;; GNU Emacs is free software: you can redistribute it and/or modify + ;; it under the terms of the GNU General Public License as published by + ;; the Free Software Foundation, either version 3 of the License, or + ;; (at your option) any later version. + + ;; GNU Emacs is distributed in the hope that it will be useful, + ;; but WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ;; GNU General Public License for more details. + + ;; You should have received a copy of the GNU General Public License + ;; along with GNU Emacs. If not, see . + + ;;; Commentary: + + ;; Function `iso-accents-mode' activates a minor mode in which + ;; typewriter "dead keys" are emulated. The purpose of this emulation + ;; is to provide a simple means for inserting accented characters + ;; according to the ISO-8859-1...3 character sets. + ;; + ;; In `iso-accents-mode', pseudo accent characters are used to + ;; introduce accented keys. The pseudo-accent characters are: + ;; + ;; ' (minute) -> acute accent + ;; ` (backtick) -> grave accent + ;; " (second) -> diaeresis + ;; ^ (caret) -> circumflex + ;; ~ (tilde) -> tilde over the character + ;; / (slash) -> slash through the character. + ;; Also: /A is A-with-ring and /E is AE ligature. + ;; These two are enabled only if you set iso-accents-enable + ;; to include them: + ;; . (period) -> dot over the character (some languages only) + ;; , (cedilla) -> cedilla under the character (some languages only) + ;; + ;; The action taken depends on the key that follows the pseudo accent. + ;; In general: + ;; + ;; pseudo-accent + appropriate letter -> accented letter + ;; pseudo-accent + space -> pseudo-accent (except comma and period) + ;; pseudo-accent + pseudo-accent -> accent (if available) + ;; pseudo-accent + other -> pseudo-accent + other + ;; + ;; If the pseudo-accent is followed by anything else than a + ;; self-insert-command, the dead-key code is terminated, the + ;; pseudo-accent inserted ‘as is’ and the bell is rung to signal this. + ;; + ;; Function `iso-accents-mode' can be used to enable the iso accents + ;; minor mode, or disable it. + + ;; If you want only some of these characters to serve as accents, + ;; add a language to `iso-languages' which specifies the accent characters + ;; that you want, then select the language with `iso-accents-customize'. + + ;;; Code: + + (provide 'iso-acc) + + (defgroup iso-acc nil + "Minor mode providing electric accent keys." + :prefix "iso-accents-" + :group 'i18n) + + (defcustom iso-accents-insert-offset nonascii-insert-offset + "Offset added by ISO Accents mode to character codes 0200 and above." + :type 'integer + :group 'iso-acc) + + (defvar iso-languages + '(("catalan" + ;; Note this includes some extra characters used in Spanish, + ;; on the idea that someone who uses Catalan is likely to use Spanish + ;; as well. + (?' (?A . ?\301) (?E . ?\311) (?I . ?\315) (?O . ?\323) (?U . ?\332) + (?a . ?\341) (?e . ?\351) (?i . ?\355) (?o . ?\363) (?u . ?\372) + (?\ . ?')) + (?` (?A . ?\300) (?E . ?\310) (?O . ?\322) + (?a . ?\340) (?e . ?\350) (?o . ?\362) + (?\ . ?`)) + (?\" (?I . ?\317) (?U . ?\334) (?i . ?\357) (?u . ?\374) + (?\ . ?\")) + (?~ (?C . ?\307) (?N . ?\321) (?c . ?\347) (?n . ?\361) + (?> . ?\273) (?< . ?\253) (?! . ?\241) (?? . ?\277) + (?\ . ?\~))) + + ("esperanto" + (?^ (?H . ?\246) (?J . ?\254) (?h . ?\266) (?j . ?\274) (?C . ?\306) + (?G . ?\330) (?S . ?\336) (?c . ?\346) (?g . ?\370) (?s . ?\376) + (?^ . ?^) (?\ . ?^)) + (?~ (?U . ?\335) (?u . ?\375) (?\ . ?~))) + + ("french" + (?' (?E . ?\311) (?C . ?\307) (?e . ?\351) (?c . ?\347) + (?\ . ?')) + (?` (?A . ?\300) (?E . ?\310) (?U . ?\331) + (?a . ?\340) (?e . ?\350) (?u . ?\371) + (?\ . ?`)) + (?^ (?A . ?\302) (?E . ?\312) (?I . ?\316) (?O . ?\324) (?U . ?\333) + (?a . ?\342) (?e . ?\352) (?i . ?\356) (?o . ?\364) (?u . ?\373) + (?\ . ?^)) + (?\" (?E . ?\313) (?I . ?\317) + (?e . ?\353) (?i . ?\357) + (?\ . ?\")) + (?~ (?< . ?\253) (?> . ?\273) (?C . ?\307) (?c . ?\347) + (?\ . ?~)) + (?, (?C . ?\307) (?c . ?\347) (?\ . ?\,))) + + ("german" + (?\" (?A . ?\304) (?O . ?\326) (?U . ?\334) + (?a . ?\344) (?o . ?\366) (?u . ?\374) (?s . ?\337) (?\ . ?\"))) + + ("irish" + (?' (?A . ?\301) (?E . ?\311) (?I . ?\315) (?O . ?\323) (?U . ?\332) + (?a . ?\341) (?e . ?\351) (?i . ?\355) (?o . ?\363) (?u . ?\372) + (?\ . ?'))) + + ("portuguese" + (?' (?A . ?\301) (?E . ?\311) (?I . ?\315) (?O . ?\323) (?U . ?\332) + (?C . ?\307) (?a . ?\341) (?e . ?\351) (?i . ?\355) (?o . ?\363) + (?u . ?\372) (?c . ?\347) + (?\ . ?')) + (?` (?A . ?\300) (?a . ?\340) + (?\ . ?`)) + (?^ (?A . ?\302) (?E . ?\312) (?O . ?\324) + (?a . ?\342) (?e . ?\352) (?o . ?\364) + (?\ . ?^)) + (?\" (?U . ?\334) (?u . ?\374) + (?\ . ?\")) + (?~ (?A . ?\303) (?O . ?\325) (?a . ?\343) (?o . ?\365) + (?C . ?\307) (?N . ?\321) (?c . ?\347) (?n . ?\361) + (?\ . ?~)) + (?, (?c . ?\347) (?C . ?\307) (?, . ?,))) + + ("spanish" + (?' (?A . ?\301) (?E . ?\311) (?I . ?\315) (?O . ?\323) (?U . ?\332) + (?a . ?\341) (?e . ?\351) (?i . ?\355) (?o . ?\363) (?u . ?\372) + (?\ . ?')) + (?\" (?U . ?\334) (?u . ?\374) (?\ . ?\")) + (?\~ (?N . ?\321) (?n . ?\361) (?> . ?\273) (?< . ?\253) (?! . ?\241) + (?? . ?\277) (?\ . ?\~))) + + ("latin-1" + (?' (?A . ?\301) (?E . ?\311) (?I . ?\315) (?O . ?\323) (?U . ?\332) + (?Y . ?\335) (?a . ?\341) (?e . ?\351) (?i . ?\355) (?o . ?\363) + (?u . ?\372) (?y . ?\375) (?' . ?\264) + (?\ . ?')) + (?` (?A . ?\300) (?E . ?\310) (?I . ?\314) (?O . ?\322) (?U . ?\331) + (?a . ?\340) (?e . ?\350) (?i . ?\354) (?o . ?\362) (?u . ?\371) + (?` . ?`) (?\ . ?`)) + (?^ (?A . ?\302) (?E . ?\312) (?I . ?\316) (?O . ?\324) (?U . ?\333) + (?a . ?\342) (?e . ?\352) (?i . ?\356) (?o . ?\364) (?u . ?\373) + (?^ . ?^) (?\ . ?^)) + (?\" (?A . ?\304) (?E . ?\313) (?I . ?\317) (?O . ?\326) (?U . ?\334) + (?a . ?\344) (?e . ?\353) (?i . ?\357) (?o . ?\366) (?s . ?\337) + (?u . ?\374) (?y . ?\377) + (?\" . ?\250) (?\ . ?\")) + (?~ (?A . ?\303) (?C . ?\307) (?D . ?\320) (?N . ?\321) (?O . ?\325) + (?T . ?\336) (?a . ?\343) (?c . ?\347) (?d . ?\360) (?n . ?\361) + (?o . ?\365) (?t . ?\376) + (?> . ?\273) (?< . ?\253) (?! . ?\241) (?? . ?\277) + (?\~ . ?\270) (?\ . ?~)) + (?/ (?A . ?\305) (?E . ?\306) (?O . ?\330) (?a . ?\345) (?e . ?\346) + (?o . ?\370) + (?/ . ?\260) (?\ . ?/))) + + ("latin-2" latin-iso8859-2 + (?' (?A . ?\301) (?C . ?\306) (?D . ?\320) (?E . ?\311) (?I . ?\315) + (?L . ?\305) (?N . ?\321) (?O . ?\323) (?R . ?\300) (?S . ?\246) + (?U . ?\332) (?Y . ?\335) (?Z . ?\254) + (?a . ?\341) (?c . ?\346) (?d . ?\360) (?e . ?\351) (?i . ?\355) + (?l . ?\345) (?n . ?\361) (?o . ?\363) (?r . ?\340) (?s . ?\266) + (?u . ?\372) (?y . ?\375) (?z . ?\274) + (?' . ?\264) (?\ . ?')) + (?` (?A . ?\241) (?C . ?\307) (?E . ?\312) (?L . ?\243) (?S . ?\252) + (?T . ?\336) (?Z . ?\257) + (?a . ?\261) (?l . ?\263) (?c . ?\347) (?e . ?\352) (?s . ?\272) + (?t . ?\376) (?z . ?\277) + (?` . ?\252) + (?. . ?\377) (?\ . ?`)) + (?^ (?A . ?\302) (?I . ?\316) (?O . ?\324) + (?a . ?\342) (?i . ?\356) (?o . ?\364) + (?^ . ?^) ; no special code? + (?\ . ?^)) + (?\" (?A . ?\304) (?E . ?\313) (?O . ?\326) (?U . ?\334) + (?a . ?\344) (?e . ?\353) (?o . ?\366) (?s . ?\337) (?u . ?\374) + (?\" . ?\250) + (?\ . ?\")) + (?~ (?A . ?\303) (?C . ?\310) (?D . ?\317) (?L . ?\245) (?N . ?\322) + (?O . ?\325) (?R . ?\330) (?S . ?\251) (?T . ?\253) (?U . ?\333) + (?Z . ?\256) + (?a . ?\343) (?c . ?\350) (?d . ?\357) (?l . ?\265) (?n . ?\362) + (?o . ?\365) (?r . ?\370) (?s . ?\271) (?t . ?\273) (?u . ?\373) + (?z . ?\276) + (?v . ?\242) ; v accent + (?\~ . ?\242) ; v accent + (?\. . ?\270) ; cedilla accent + (?\ . ?~))) + + ("latin-3" latin-iso8859-3 + (?' (?A . ?\301) (?E . ?\311) (?I . ?\315) (?O . ?\323) (?U . ?\332) + (?a . ?\341) (?e . ?\351) (?i . ?\355) (?o . ?\363) (?u . ?\372) + (?' . ?\264) (?\ . ?')) + (?` (?A . ?\300) (?E . ?\310) (?I . ?\314) (?O . ?\322) (?U . ?\331) + (?a . ?\340) (?e . ?\350) (?i . ?\354) (?o . ?\362) (?u . ?\371) + (?` . ?`) (?\ . ?`)) + (?^ (?A . ?\302) (?C . ?\306) (?E . ?\312) (?G . ?\330) (?H . ?\246) + (?I . ?\316) (?J . ?\254) (?O . ?\324) (?S . ?\336) (?U . ?\333) + (?a . ?\342) (?c . ?\346) (?e . ?\352) (?g . ?\370) (?h . ?\266) + (?i . ?\356) (?j . ?\274) (?o . ?\364) (?s . ?\376) (?u . ?\373) + (?^ . ?^) (?\ . ?^)) + (?\" (?A . ?\304) (?E . ?\313) (?I . ?\317) (?O . ?\326) (?U . ?\334) + (?a . ?\344) (?e . ?\353) (?i . ?\357) (?o . ?\366) (?u . ?\374) + (?s . ?\337) + (?\" . ?\250) (?\ . ?\")) + (?~ (?A . ?\303) (?C . ?\307) (?D . ?\320) (?N . ?\321) (?O . ?\325) + (?a . ?\343) (?c . ?\347) (?d . ?\360) (?n . ?\361) (?o . ?\365) + (?$ . ?\245) (?S . ?\252) (?s . ?\272) (?G . ?\253) (?g . ?\273) + (?U . ?\335) (?u . ?\375) (?` . ?\242) + (?~ . ?\270) (?\ . ?~)) + (?/ (?C . ?\305) (?G . ?\325) (?H . ?\241) (?I . ?\251) (?Z . ?\257) + (?c . ?\345) (?g . ?\365) (?h . ?\261) (?i . ?\271) (?z . ?\277) + (?r . ?\256) + (?. . ?\377) (?# . ?\243) (?$ . ?\244) + (?/ . ?\260) (?\ . ?/)) + (?. (?C . ?\305) (?G . ?\325) (?I . ?\251) (?Z . ?\257) - (?c . ?\345) (?g . ?\365) (?z . ?\277)))) ++ (?c . ?\345) (?g . ?\365) (?z . ?\277)))) + "List of language-specific customizations for the ISO Accents mode. + + Each element of the list is of the form + + (LANGUAGE [CHARSET] + (PSEUDO-ACCENT MAPPINGS) + (PSEUDO-ACCENT MAPPINGS) + ...) + + LANGUAGE is a string naming the language. + CHARSET (which may be omitted) is the symbol name + of the character set used in this language. + If CHARSET is omitted, latin-iso8859-1 is the default. + PSEUDO-ACCENT is a char specifying an accent key. + MAPPINGS are cons cells of the form (CHAR . ISO-CHAR). + + The net effect is that the key sequence PSEUDO-ACCENT CHAR is mapped + to ISO-CHAR on input.") + + (defvar iso-language nil + "Language for which ISO Accents mode is currently customized. + Change it with the `iso-accents-customize' function.") + + (defvar iso-accents-list nil + "Association list for ISO accent combinations, for the chosen language.") + + (defcustom iso-accents-mode nil + "Non-nil enables ISO Accents mode. + Setting this variable makes it local to the current buffer. + See the function `iso-accents-mode'." + :type 'boolean + :group 'iso-acc) + (make-variable-buffer-local 'iso-accents-mode) + + (defcustom iso-accents-enable '(?' ?` ?^ ?\" ?~ ?/) + "List of accent keys that become prefixes in ISO Accents mode. + The default is (?\\=' ?\\=` ?^ ?\" ?~ ?/), which contains all the supported + accent keys. If you set this variable to a list in which some of those + characters are missing, the missing ones do not act as accents. + + Note that if you specify a language with `iso-accents-customize', + that can also turn off certain prefixes (whichever ones are not needed in + the language you choose)." + :type '(repeat character) + :group 'iso-acc) + + (defun iso-accents-accent-key (prompt) + "Modify the following character by adding an accent to it." + ;; Pick up the accent character. + (if (and iso-accents-mode + (memq last-input-event iso-accents-enable)) + (iso-accents-compose prompt) + (vector last-input-event))) + + + ;; The iso-accents-compose function is called deep inside Emacs' read + ;; key sequence machinery, so the call to read-event below actually + ;; recurses into that machinery. Doing that does not cause any + ;; problem on its own, but read-event will have marked the window's + ;; display matrix to be accurate -- which is broken by the subsequent + ;; call to delete-region. Therefore, we must call force-window-update + ;; after delete-region to explicitly clear the accurate state of the + ;; window's display matrix. + + (defun iso-accents-compose (prompt) + (let* ((first-char last-input-event) + (list (assq first-char iso-accents-list)) + ;; Wait for the second key and look up the combination. + (second-char (if (or prompt + (not (eq (key-binding "a") + 'self-insert-command)) + ;; Not at start of a key sequence. + (> (length (this-single-command-keys)) 1) + ;; Called from anything but the command loop. + this-command) + (progn + (message "%s%c" + (or prompt "Compose with ") + first-char) + (read-event)) + (insert first-char) + (prog1 (read-event) + (delete-region (1- (point)) (point)) + ;; Display is no longer up-to-date. + (force-window-update (selected-window))))) + (entry (cdr (assq second-char list)))) + (if entry + ;; Found it: return the mapped char + (vector + (if (and enable-multibyte-characters + (>= entry ?\200)) + (+ iso-accents-insert-offset entry) + entry)) + ;; Otherwise, advance and schedule the second key for execution. + (push second-char unread-command-events) + (vector first-char)))) + + ;; It is a matter of taste if you want the minor mode indicated + ;; in the mode line... + ;; If so, uncomment the next four lines. + ;; (or (assq 'iso-accents-mode minor-mode-alist) + ;; (setq minor-mode-alist + ;; (append minor-mode-alist + ;; '((iso-accents-mode " ISO-Acc"))))) + + ;;;###autoload + (defun iso-accents-mode (&optional arg) + "Toggle ISO Accents mode, in which accents modify the following letter. + This permits easy insertion of accented characters according to ISO-8859-1. + When Iso-accents mode is enabled, accent character keys + \(\\=`, \\=', \", ^, / and ~) do not self-insert; instead, they modify the following + letter key so that it inserts an ISO accented letter. + + You can customize ISO Accents mode to a particular language + with the command `iso-accents-customize'. + + Special combinations: ~c gives a c with cedilla, + ~d gives an Icelandic eth (d with dash). + ~t gives an Icelandic thorn. + \"s gives German sharp s. + /a gives a with ring. + /e gives an a-e ligature. + ~< and ~> give guillemots. + ~! gives an inverted exclamation mark. + ~? gives an inverted question mark. + + With an argument, a positive argument enables ISO Accents mode, + and a negative argument disables it." + + (interactive "P") + + (if (if arg + ;; Negative arg means switch it off. + (<= (prefix-numeric-value arg) 0) + ;; No arg means toggle. + iso-accents-mode) + (setq iso-accents-mode nil) + + ;; Enable electric accents. + (setq iso-accents-mode t))) + + (defun iso-accents-customize (language) + "Customize the ISO accents machinery for a particular language. + It selects the customization based on the specifications in the + `iso-languages' variable." + (interactive (list (completing-read "Language: " iso-languages nil t))) + (let ((table (cdr (assoc language iso-languages))) + all-accents tail) + (if (not table) + (error "Unknown language `%s'" language) + (setq iso-accents-insert-offset (- (make-char (if (symbolp (car table)) + (car table) + 'latin-iso8859-1)) + 128)) + (if (symbolp (car table)) + (setq table (cdr table))) + (setq iso-language language + iso-accents-list table) + (if key-translation-map + (substitute-key-definition + 'iso-accents-accent-key nil key-translation-map) + (setq key-translation-map (make-sparse-keymap))) + ;; Set up translations for all the characters that are used as + ;; accent prefixes in this language. + (setq tail iso-accents-list) + (while tail + (define-key key-translation-map (vector (car (car tail))) + 'iso-accents-accent-key) + (setq tail (cdr tail)))))) + + (defun iso-accentuate (start end) + "Convert two-character sequences in region into accented characters. + Noninteractively, this operates on text from START to END. + This uses the same conversion that ISO Accents mode uses for type-in." + (interactive "r") + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char start) + (forward-char 1) + (let (entry) + (while (< (point) end) + (if (and (memq (preceding-char) iso-accents-enable) + (setq entry (cdr (assq (following-char) (assq (preceding-char) iso-accents-list))))) + (progn + (forward-char -1) + (delete-char 2) + (insert entry) + (setq end (1- end))) + (forward-char 1))))))) + + (defun iso-accent-rassoc-unit (value alist) + (let (elt acc) + (while (and alist (not elt)) + (setq acc (car (car alist)) + elt (car (rassq value (cdr (car alist)))) + alist (cdr alist))) + (if elt + (cons acc elt)))) + + (defun iso-unaccentuate (start end) + "Convert accented characters in the region into two-character sequences. + Noninteractively, this operates on text from START to END. + This uses the opposite of the conversion done by ISO Accents mode for type-in." + (interactive "r") + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char start) + (let (entry) + (while (< (point) end) + (if (and (> (following-char) 127) + (setq entry (iso-accent-rassoc-unit (following-char) + iso-accents-list))) + (progn + (delete-char 1) + (insert (car entry) (cdr entry)) + (setq end (1+ end))) + (forward-char 1))))))) + + (defun iso-deaccentuate (start end) + "Convert accented characters in the region into unaccented characters. + Noninteractively, this operates on text from START to END." + (interactive "r") + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char start) + (let (entry) + (while (< (point) end) + (if (and (> (following-char) 127) + (setq entry (iso-accent-rassoc-unit (following-char) + iso-accents-list))) + (progn + (delete-char 1) + (insert (cdr entry))) + (forward-char 1))))))) + + ;; Set up the default settings. + (iso-accents-customize "latin-1") + + ;; Use Iso-Accents mode in the minibuffer + ;; if it was in use in the previous buffer. + (defun iso-acc-minibuf-setup () + (setq iso-accents-mode + (with-current-buffer (window-buffer minibuffer-scroll-window) + iso-accents-mode))) + + (add-hook 'minibuffer-setup-hook 'iso-acc-minibuf-setup) + + ;;; iso-acc.el ends here diff --cc lisp/plstore.el index 01bdd144ac0,00000000000..b9025433b11 mode 100644,000000..100644 --- a/lisp/plstore.el +++ b/lisp/plstore.el @@@ -1,572 -1,0 +1,572 @@@ +;;; plstore.el --- secure plist store -*- lexical-binding: t -*- - ;; Copyright (C) 2011-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2011-2017 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Keywords: PGP, GnuPG + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary + +;; Plist based data store providing search and partial encryption. +;; +;; Creating: +;; +;; ;; Open a new store associated with ~/.emacs.d/auth.plist. +;; (setq store (plstore-open (expand-file-name "~/.emacs.d/auth.plist"))) +;; ;; Both `:host' and `:port' are public property. +;; (plstore-put store "foo" '(:host "foo.example.org" :port 80) nil) +;; ;; No encryption will be needed. +;; (plstore-save store) +;; +;; ;; `:user' is marked as secret. +;; (plstore-put store "bar" '(:host "bar.example.org") '(:user "test")) +;; ;; `:password' is marked as secret. +;; (plstore-put store "baz" '(:host "baz.example.org") '(:password "test")) +;; ;; Those secret properties are encrypted together. +;; (plstore-save store) +;; +;; ;; Kill the buffer visiting ~/.emacs.d/auth.plist. +;; (plstore-close store) +;; +;; Searching: +;; +;; (setq store (plstore-open (expand-file-name "~/.emacs.d/auth.plist"))) +;; +;; ;; As the entry "foo" associated with "foo.example.org" has no +;; ;; secret properties, no need to decryption. +;; (plstore-find store '(:host ("foo.example.org"))) +;; +;; ;; As the entry "bar" associated with "bar.example.org" has a +;; ;; secret property `:user', Emacs tries to decrypt the secret (and +;; ;; thus you will need to input passphrase). +;; (plstore-find store '(:host ("bar.example.org"))) +;; +;; ;; While the entry "baz" associated with "baz.example.org" has also +;; ;; a secret property `:password', it is encrypted together with +;; ;; `:user' of "bar", so no need to decrypt the secret. +;; (plstore-find store '(:host ("bar.example.org"))) +;; +;; (plstore-close store) +;; +;; Editing: +;; +;; This file also provides `plstore-mode', a major mode for editing +;; the PLSTORE format file. Visit a non-existing file and put the +;; following line: +;; +;; (("foo" :host "foo.example.org" :secret-user "user")) +;; +;; where the prefixing `:secret-' means the property (without +;; `:secret-' prefix) is marked as secret. Thus, when you save the +;; buffer, the `:secret-user' property is encrypted as `:user'. +;; +;; You can toggle the view between encrypted form and the decrypted +;; form with C-c C-c. + +;;; Code: + +(require 'epg) + +(defgroup plstore nil + "Searchable, partially encrypted, persistent plist store" + :version "24.1" + :group 'files) + +(defcustom plstore-select-keys 'silent + "Control whether or not to pop up the key selection dialog. + +If t, always asks user to select recipients. +If nil, query user only when a file's default recipients are not +known (i.e. `plstore-encrypt-to' is not locally set in the buffer +visiting a plstore file). +If neither t nor nil, doesn't ask user." + :type '(choice (const :tag "Ask always" t) + (const :tag "Ask when recipients are not set" nil) + (const :tag "Don't ask" silent)) + :group 'plstore) + +(defcustom plstore-encrypt-to nil + "Recipient(s) used for encrypting secret entries. +May either be a string or a list of strings. If it is nil, +symmetric encryption will be used." + :type '(choice (const nil) (repeat :tag "Recipient(s)" string)) + :group 'plstore) + +(put 'plstore-encrypt-to 'safe-local-variable + (lambda (val) + (or (stringp val) + (and (listp val) + (catch 'safe + (mapc (lambda (elt) + (unless (stringp elt) + (throw 'safe nil))) + val) + t))))) + +(put 'plstore-encrypt-to 'permanent-local t) + +(defvar plstore-encoded nil) + +(put 'plstore-encoded 'permanent-local t) + +(defvar plstore-cache-passphrase-for-symmetric-encryption nil) +(defvar plstore-passphrase-alist nil) + +(defun plstore-passphrase-callback-function (_context _key-id plstore) + (if plstore-cache-passphrase-for-symmetric-encryption + (let* ((file (file-truename (plstore-get-file plstore))) + (entry (assoc file plstore-passphrase-alist)) + passphrase) + (or (copy-sequence (cdr entry)) + (progn + (unless entry + (setq entry (list file) + plstore-passphrase-alist + (cons entry + plstore-passphrase-alist))) + (setq passphrase + (read-passwd (format "Passphrase for PLSTORE %s: " + (plstore--get-buffer plstore)))) + (setcdr entry (copy-sequence passphrase)) + passphrase))) + (read-passwd (format "Passphrase for PLSTORE %s: " + (plstore--get-buffer plstore))))) + +(defun plstore-progress-callback-function (_context _what _char current total + handback) + (if (= current total) + (message "%s...done" handback) + (message "%s...%d%%" handback + (if (> total 0) (floor (* (/ current (float total)) 100)) 0)))) + +(defun plstore--get-buffer (arg) + (aref arg 0)) + +(defun plstore--get-alist (arg) + (aref arg 1)) + +(defun plstore--get-encrypted-data (arg) + (aref arg 2)) + +(defun plstore--get-secret-alist (arg) + (aref arg 3)) + +(defun plstore--get-merged-alist (arg) + (aref arg 4)) + +(defun plstore--set-buffer (arg buffer) + (aset arg 0 buffer)) + +(defun plstore--set-alist (arg plist) + (aset arg 1 plist)) + +(defun plstore--set-encrypted-data (arg encrypted-data) + (aset arg 2 encrypted-data)) + +(defun plstore--set-secret-alist (arg secret-alist) + (aset arg 3 secret-alist)) + +(defun plstore--set-merged-alist (arg merged-alist) + (aset arg 4 merged-alist)) + +(defun plstore-get-file (arg) + (buffer-file-name (plstore--get-buffer arg))) + +(defun plstore--make (&optional buffer alist encrypted-data secret-alist + merged-alist) + (vector buffer alist encrypted-data secret-alist merged-alist)) + +(defun plstore--init-from-buffer (plstore) + (goto-char (point-min)) + (when (looking-at ";;; public entries") + (forward-line) + (plstore--set-alist plstore (read (point-marker))) + (forward-sexp) + (forward-char) + (when (looking-at ";;; secret entries") + (forward-line) + (plstore--set-encrypted-data plstore (read (point-marker)))) + (plstore--merge-secret plstore))) + +;;;###autoload +(defun plstore-open (file) + "Create a plstore instance associated with FILE." + (let* ((filename (file-truename file)) + (buffer (or (find-buffer-visiting filename) + (generate-new-buffer (format " plstore %s" filename)))) + (store (plstore--make buffer))) + (with-current-buffer buffer + (erase-buffer) + (condition-case nil + (insert-file-contents-literally file) + (error)) + (setq buffer-file-name (file-truename file)) + (set-buffer-modified-p nil) + (plstore--init-from-buffer store) + store))) + +(defun plstore-revert (plstore) + "Replace current data in PLSTORE with the file on disk." + (with-current-buffer (plstore--get-buffer plstore) + (revert-buffer t t) + (plstore--init-from-buffer plstore))) + +(defun plstore-close (plstore) + "Destroy a plstore instance PLSTORE." + (kill-buffer (plstore--get-buffer plstore))) + +(defun plstore--merge-secret (plstore) + (let ((alist (plstore--get-secret-alist plstore)) + modified-alist + modified-plist + modified-entry + entry + plist + placeholder) + (plstore--set-merged-alist + plstore + (copy-tree (plstore--get-alist plstore))) + (setq modified-alist (plstore--get-merged-alist plstore)) + (while alist + (setq entry (car alist) + alist (cdr alist) + plist (cdr entry) + modified-entry (assoc (car entry) modified-alist) + modified-plist (cdr modified-entry)) + (while plist + (setq placeholder + (plist-member + modified-plist + (intern (concat ":secret-" + (substring (symbol-name (car plist)) 1))))) + (if placeholder + (setcar placeholder (car plist))) + (setq modified-plist + (plist-put modified-plist (car plist) (car (cdr plist)))) + (setq plist (nthcdr 2 plist))) + (setcdr modified-entry modified-plist)))) + +(defun plstore--decrypt (plstore) + (if (plstore--get-encrypted-data plstore) + (let ((context (epg-make-context 'OpenPGP)) + plain) + (epg-context-set-passphrase-callback + context + (cons #'plstore-passphrase-callback-function + plstore)) + (epg-context-set-progress-callback + context + (cons #'plstore-progress-callback-function + (format "Decrypting %s" (plstore-get-file plstore)))) + (condition-case error + (setq plain + (epg-decrypt-string context + (plstore--get-encrypted-data plstore))) + (error + (let ((entry (assoc (plstore-get-file plstore) + plstore-passphrase-alist))) + (if entry + (setcdr entry nil))) + (signal (car error) (cdr error)))) + (plstore--set-secret-alist plstore (car (read-from-string plain))) + (plstore--merge-secret plstore) + (plstore--set-encrypted-data plstore nil)))) + +(defun plstore--match (entry keys skip-if-secret-found) + (let ((result t) key-name key-value prop-value secret-name) + (while keys + (setq key-name (car keys) + key-value (car (cdr keys)) + prop-value (plist-get (cdr entry) key-name)) + (unless (member prop-value key-value) + (if skip-if-secret-found + (progn + (setq secret-name + (intern (concat ":secret-" + (substring (symbol-name key-name) 1)))) + (if (plist-member (cdr entry) secret-name) + (setq result 'secret) + (setq result nil + keys nil))) + (setq result nil + keys nil))) + (setq keys (nthcdr 2 keys))) + result)) + +(defun plstore-find (plstore keys) + "Perform search on PLSTORE with KEYS. +KEYS is a plist." + (let (entries alist entry match decrypt plist) + ;; First, go through the merged plist alist and collect entries + ;; matched with keys. + (setq alist (plstore--get-merged-alist plstore)) + (while alist + (setq entry (car alist) + alist (cdr alist) + match (plstore--match entry keys t)) + (if (eq match 'secret) + (setq decrypt t) + (when match + (setq plist (cdr entry)) + (while plist + (if (string-match "\\`:secret-" (symbol-name (car plist))) + (setq decrypt t + plist nil)) + (setq plist (nthcdr 2 plist))) + (setq entries (cons entry entries))))) + ;; Second, decrypt the encrypted plist and try again. + (when decrypt + (setq entries nil) + (plstore--decrypt plstore) + (setq alist (plstore--get-merged-alist plstore)) + (while alist + (setq entry (car alist) + alist (cdr alist) + match (plstore--match entry keys nil)) + (if match + (setq entries (cons entry entries))))) + (nreverse entries))) + +(defun plstore-get (plstore name) + "Get an entry with NAME in PLSTORE." + (let ((entry (assoc name (plstore--get-merged-alist plstore))) + plist) + (setq plist (cdr entry)) + (while plist + (if (string-match "\\`:secret-" (symbol-name (car plist))) + (progn + (plstore--decrypt plstore) + (setq entry (assoc name (plstore--get-merged-alist plstore)) + plist nil)) + (setq plist (nthcdr 2 plist)))) + entry)) + +(defun plstore-put (plstore name keys secret-keys) + "Put an entry with NAME in PLSTORE. +KEYS is a plist containing non-secret data. +SECRET-KEYS is a plist containing secret data." + (let (entry + plist + secret-plist + symbol) + (if secret-keys + (plstore--decrypt plstore)) + (while secret-keys + (setq symbol + (intern (concat ":secret-" + (substring (symbol-name (car secret-keys)) 1)))) + (setq plist (plist-put plist symbol t) + secret-plist (plist-put secret-plist + (car secret-keys) (car (cdr secret-keys))) + secret-keys (nthcdr 2 secret-keys))) + (while keys + (setq symbol + (intern (concat ":secret-" + (substring (symbol-name (car keys)) 1)))) + (setq plist (plist-put plist (car keys) (car (cdr keys))) + keys (nthcdr 2 keys))) + (setq entry (assoc name (plstore--get-alist plstore))) + (if entry + (setcdr entry plist) + (plstore--set-alist + plstore + (cons (cons name plist) (plstore--get-alist plstore)))) + (when secret-plist + (setq entry (assoc name (plstore--get-secret-alist plstore))) + (if entry + (setcdr entry secret-plist) + (plstore--set-secret-alist + plstore + (cons (cons name secret-plist) (plstore--get-secret-alist plstore))))) + (plstore--merge-secret plstore))) + +(defun plstore-delete (plstore name) + "Delete an entry with NAME from PLSTORE." + (let ((entry (assoc name (plstore--get-alist plstore)))) + (if entry + (plstore--set-alist + plstore + (delq entry (plstore--get-alist plstore)))) + (setq entry (assoc name (plstore--get-secret-alist plstore))) + (if entry + (plstore--set-secret-alist + plstore + (delq entry (plstore--get-secret-alist plstore)))) + (setq entry (assoc name (plstore--get-merged-alist plstore))) + (if entry + (plstore--set-merged-alist + plstore + (delq entry (plstore--get-merged-alist plstore)))))) + +(defvar pp-escape-newlines) +(defun plstore--insert-buffer (plstore) + (insert ";;; public entries -*- mode: plstore -*- \n" + (pp-to-string (plstore--get-alist plstore))) + (if (plstore--get-secret-alist plstore) + (let ((context (epg-make-context 'OpenPGP)) + (pp-escape-newlines nil) + (recipients + (cond + ((listp plstore-encrypt-to) plstore-encrypt-to) + ((stringp plstore-encrypt-to) (list plstore-encrypt-to)))) + cipher) + (setf (epg-context-armor context) t) + (epg-context-set-passphrase-callback + context + (cons #'plstore-passphrase-callback-function + plstore)) + (setq cipher (epg-encrypt-string + context + (pp-to-string + (plstore--get-secret-alist plstore)) + (if (or (eq plstore-select-keys t) + (and (null plstore-select-keys) + (not (local-variable-p 'plstore-encrypt-to + (current-buffer))))) + (epa-select-keys + context + "Select recipients for encryption. +If no one is selected, symmetric encryption will be performed. " + recipients) + (if plstore-encrypt-to + (epg-list-keys context recipients))))) + (goto-char (point-max)) + (insert ";;; secret entries\n" (pp-to-string cipher))))) + +(defun plstore-save (plstore) + "Save the contents of PLSTORE associated with a FILE." + (with-current-buffer (plstore--get-buffer plstore) + (erase-buffer) + (plstore--insert-buffer plstore) + (save-buffer))) + +(defun plstore--encode (plstore) + (plstore--decrypt plstore) + (let ((merged-alist (plstore--get-merged-alist plstore))) + (concat "(" + (mapconcat + (lambda (entry) + (setq entry (copy-sequence entry)) + (let ((merged-plist (cdr (assoc (car entry) merged-alist))) + (plist (cdr entry))) + (while plist + (if (string-match "\\`:secret-" (symbol-name (car plist))) + (setcar (cdr plist) + (plist-get + merged-plist + (intern (concat ":" + (substring (symbol-name + (car plist)) + (match-end 0))))))) + (setq plist (nthcdr 2 plist))) + (prin1-to-string entry))) + (plstore--get-alist plstore) + "\n") + ")"))) + +(defun plstore--decode (string) + (let* ((alist (car (read-from-string string))) + (pointer alist) + secret-alist + plist + entry) + (while pointer + (unless (stringp (car (car pointer))) + (error "Invalid PLSTORE format %s" string)) + (setq plist (cdr (car pointer))) + (while plist + (when (string-match "\\`:secret-" (symbol-name (car plist))) + (setq entry (assoc (car (car pointer)) secret-alist)) + (unless entry + (setq entry (list (car (car pointer))) + secret-alist (cons entry secret-alist))) + (setcdr entry (plist-put (cdr entry) + (intern (concat ":" + (substring (symbol-name + (car plist)) + (match-end 0)))) + (car (cdr plist)))) + (setcar (cdr plist) t)) + (setq plist (nthcdr 2 plist))) + (setq pointer (cdr pointer))) + (plstore--make nil alist nil secret-alist))) + +(defun plstore--write-contents-functions () + (when plstore-encoded + (let ((store (plstore--decode (buffer-string))) + (file (buffer-file-name))) + (unwind-protect + (progn + (set-visited-file-name nil) + (with-temp-buffer + (plstore--insert-buffer store) + (write-region (buffer-string) nil file))) + (set-visited-file-name file) + (set-buffer-modified-p nil)) + t))) + +(defun plstore-mode-original () + "Show the original form of the this buffer." + (interactive) + (when plstore-encoded + (if (and (buffer-modified-p) + (y-or-n-p "Save buffer before reading the original form? ")) + (save-buffer)) + (erase-buffer) + (insert-file-contents-literally (buffer-file-name)) + (set-buffer-modified-p nil) + (setq plstore-encoded nil))) + +(defun plstore-mode-decoded () + "Show the decoded form of the this buffer." + (interactive) + (unless plstore-encoded + (if (and (buffer-modified-p) + (y-or-n-p "Save buffer before decoding? ")) + (save-buffer)) + (let ((store (plstore--make (current-buffer)))) + (plstore--init-from-buffer store) + (erase-buffer) + (insert + (substitute-command-keys "\ +;;; You are looking at the decoded form of the PLSTORE file.\n\ +;;; To see the original form content, do \\[plstore-mode-toggle-display]\n\n")) + (insert (plstore--encode store)) + (set-buffer-modified-p nil) + (setq plstore-encoded t)))) + +(defun plstore-mode-toggle-display () + "Toggle the display mode of PLSTORE between the original and decoded forms." + (interactive) + (if plstore-encoded + (plstore-mode-original) + (plstore-mode-decoded))) + +;;;###autoload +(define-derived-mode plstore-mode emacs-lisp-mode "PLSTORE" + "Major mode for editing PLSTORE files." + (make-local-variable 'plstore-encoded) + (add-hook 'write-contents-functions #'plstore--write-contents-functions) + (define-key plstore-mode-map "\C-c\C-c" #'plstore-mode-toggle-display) + ;; to create a new file with plstore-mode, mark it as already decoded + (if (called-interactively-p 'any) + (setq plstore-encoded t) + (plstore-mode-decoded))) + +(provide 'plstore) + +;;; plstore.el ends here diff --cc lisp/progmodes/which-func.el index 2fc24a8cb3d,c2ea4546f88..41513340e12 --- a/lisp/progmodes/which-func.el +++ b/lisp/progmodes/which-func.el @@@ -1,6 -1,6 +1,6 @@@ -;;; which-func.el --- print current function in mode line +;;; which-func.el --- print current function in mode line -*- lexical-binding:t -*- - ;; Copyright (C) 1994, 1997-1998, 2001-2016 Free Software Foundation, + ;; Copyright (C) 1994, 1997-1998, 2001-2017 Free Software Foundation, ;; Inc. ;; Author: Alex Rezinsky diff --cc lisp/ps-def.el index fbb61b53e73,251292037d6..ea51c2a09b1 --- a/lisp/ps-def.el +++ b/lisp/ps-def.el @@@ -1,6 -1,6 +1,6 @@@ -;;; ps-def.el --- XEmacs and Emacs definitions for ps-print +;;; ps-def.el --- XEmacs and Emacs definitions for ps-print -*- lexical-binding: t -*- - ;; Copyright (C) 2007-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2007-2017 Free Software Foundation, Inc. ;; Author: Vinicius Jose Latorre ;; Kenichi Handa (multi-byte characters) diff --cc lisp/ps-print.el index 71523a90db6,1fde5e25eb2..7476ab3bb12 --- a/lisp/ps-print.el +++ b/lisp/ps-print.el @@@ -1,6 -1,6 +1,6 @@@ -;;; ps-print.el --- print text from the buffer as PostScript +;;; ps-print.el --- print text from the buffer as PostScript -*- lexical-binding: t -*- - ;; Copyright (C) 1993-2016 Free Software Foundation, Inc. + ;; Copyright (C) 1993-2017 Free Software Foundation, Inc. ;; Author: Jim Thompson (was ) ;; Jacques Duthen (was ) diff --cc lisp/registry.el index 20f8e8df257,00000000000..27664dc09ec mode 100644,000000..100644 --- a/lisp/registry.el +++ b/lisp/registry.el @@@ -1,374 -1,0 +1,374 @@@ +;;; registry.el --- Track and remember data items by various fields + - ;; Copyright (C) 2011-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2011-2017 Free Software Foundation, Inc. + +;; Author: Teodor Zlatanov +;; Keywords: data + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This library provides a general-purpose EIEIO-based registry +;; database with persistence, initialized with these fields: + +;; version: a float + +;; max-size: an integer, default most-positive-fixnum + +;; prune-factor: a float between 0 and 1, default 0.1 + +;; precious: a list of symbols + +;; tracked: a list of symbols + +;; tracker: a hash table tuned for 100 symbols to track (you should +;; only access this with the :lookup2-function and the +;; :lookup2+-function) + +;; data: a hash table with default size 10K and resize threshold 2.0 +;; (this reflects the expected usage so override it if you know better) + +;; ...plus methods to do all the work: `registry-search', +;; `registry-lookup', `registry-lookup-secondary', +;; `registry-lookup-secondary-value', `registry-insert', +;; `registry-delete', `registry-prune', `registry-size' which see + +;; and with the following properties: + +;; Every piece of data has a unique ID and some general-purpose fields +;; (F1=D1, F2=D2, F3=(a b c)...) expressed as an alist, e.g. + +;; ((F1 D1) (F2 D2) (F3 a b c)) + +;; Note that whether a field has one or many pieces of data, the data +;; is always a list of values. + +;; The user decides which fields are "precious", F2 for example. When +;; the registry is pruned, any entries without the F2 field will be +;; removed until the size is :max-size * :prune-factor _less_ than the +;; maximum database size. No entries with the F2 field will be removed +;; at PRUNE TIME, which means it may not be possible to prune back all +;; the way to the target size. + +;; When an entry is inserted, the registry will reject new entries if +;; they bring it over the :max-size limit, even if they have the F2 +;; field. + +;; The user decides which fields are "tracked", F1 for example. Any +;; new entry is then indexed by all the tracked fields so it can be +;; quickly looked up that way. The data is always a list (see example +;; above) and each list element is indexed. + +;; Precious and tracked field names must be symbols. All other +;; fields can be any other Emacs Lisp types. + +;;; Code: + +(require 'cl-lib) +(require 'eieio) +(require 'eieio-base) + +;; The version number needs to be kept outside of the class definition +;; itself. The persistent-save process does *not* write to file any +;; slot values that are equal to the default :initform value. If a +;; database object is at the most recent version, therefore, its +;; version number will not be written to file. That makes it +;; difficult to know when a database needs to be upgraded. +(defvar registry-db-version 0.2 + "The current version of the registry format.") + +(defclass registry-db (eieio-persistent) + ((version :initarg :version + :initform nil + :type (or null float) + :documentation "The registry version.") + (max-size :initarg :max-size + ;; EIEIO's :initform is not 100% compatible with CLOS in + ;; that if the form is an atom, it assumes it's constant + ;; value rather than an expression, so in order to get the value + ;; of `most-positive-fixnum', we need to use an + ;; expression that's not just a symbol. + :initform (symbol-value 'most-positive-fixnum) + :type integer + :custom integer + :documentation "The maximum number of registry entries.") + (prune-factor + :initarg :prune-factor + :initform 0.1 + :type float + :custom float + :documentation "Prune to (:max-size * :prune-factor) less + than the :max-size limit. Should be a float between 0 and 1.") + (tracked :initarg :tracked + :initform nil + :type t + :documentation "The tracked (indexed) fields, a list of symbols.") + (precious :initarg :precious + :initform nil + :type t + :documentation "The precious fields, a list of symbols.") + (tracker :initarg :tracker + :type hash-table + :documentation "The field tracking hash table.") + (data :initarg :data + :type hash-table + :documentation "The data hash table."))) + +(cl-defmethod initialize-instance :before ((this registry-db) slots) + "Check whether a registry object needs to be upgraded." + ;; Hardcoded upgrade routines. Version 0.1 to 0.2 requires the + ;; :max-soft slot to disappear, and the :max-hard slot to be renamed + ;; :max-size. + (let ((current-version + (and (plist-member slots :version) + (plist-get slots :version)))) + (when (or (null current-version) + (eql current-version 0.1)) + (setq slots + (plist-put slots :max-size (plist-get slots :max-hard))) + (setq slots + (plist-put slots :version registry-db-version)) + (cl-remf slots :max-hard) + (cl-remf slots :max-soft)))) + +(cl-defmethod initialize-instance :after ((this registry-db) slots) + "Set value of data slot of THIS after initialization." + (with-slots (data tracker) this + (unless (member :data slots) + (setq data + (make-hash-table :size 10000 :rehash-size 2.0 :test 'equal))) + (unless (member :tracker slots) + (setq tracker (make-hash-table :size 100 :rehash-size 2.0))))) + +(cl-defmethod registry-lookup ((db registry-db) keys) + "Search for KEYS in the registry-db THIS. +Returns an alist of the key followed by the entry in a list, not a cons cell." + (let ((data (oref db data))) + (delq nil + (mapcar + (lambda (k) + (when (gethash k data) + (list k (gethash k data)))) + keys)))) + +(cl-defmethod registry-lookup-breaks-before-lexbind ((db registry-db) keys) + "Search for KEYS in the registry-db THIS. +Returns an alist of the key followed by the entry in a list, not a cons cell." + (let ((data (oref db data))) + (delq nil + (cl-loop for key in keys + when (gethash key data) + collect (list key (gethash key data)))))) + +(cl-defmethod registry-lookup-secondary ((db registry-db) tracksym + &optional create) + "Search for TRACKSYM in the registry-db THIS. +When CREATE is not nil, create the secondary index hash table if needed." + (let ((h (gethash tracksym (oref db tracker)))) + (if h + h + (when create + (puthash tracksym + (make-hash-table :size 800 :rehash-size 2.0 :test 'equal) + (oref db tracker)) + (gethash tracksym (oref db tracker)))))) + +(cl-defmethod registry-lookup-secondary-value ((db registry-db) tracksym val + &optional set) + "Search for TRACKSYM with value VAL in the registry-db THIS. +When SET is not nil, set it for VAL (use t for an empty list)." + ;; either we're asked for creation or there should be an existing index + (when (or set (registry-lookup-secondary db tracksym)) + ;; set the entry if requested, + (when set + (puthash val (if (eq t set) '() set) + (registry-lookup-secondary db tracksym t))) + (gethash val (registry-lookup-secondary db tracksym)))) + +(defun registry--match (mode entry check-list) + ;; for all members + (when check-list + (let ((key (nth 0 (nth 0 check-list))) + (vals (cdr-safe (nth 0 check-list))) + found) + (while (and key vals (not found)) + (setq found (cl-case mode + (:member + (member (car-safe vals) (cdr-safe (assoc key entry)))) + (:regex + (string-match (car vals) + (mapconcat + 'prin1-to-string + (cdr-safe (assoc key entry)) + "\0")))) + vals (cdr-safe vals))) + (or found + (registry--match mode entry (cdr-safe check-list)))))) + +(cl-defmethod registry-search ((db registry-db) &rest spec) + "Search for SPEC across the registry-db THIS. +For example calling with `:member \\='(a 1 2)' will match entry \((a 3 1)). +Calling with `:all t' (any non-nil value) will match all. +Calling with `:regex \\='(a \"h.llo\")' will match entry \(a \"hullo\" \"bye\"). +The test order is to check :all first, then :member, then :regex." + (when db + (let ((all (plist-get spec :all)) + (member (plist-get spec :member)) + (regex (plist-get spec :regex))) + (cl-loop for k being the hash-keys of (oref db data) + using (hash-values v) + when (or + ;; :all non-nil returns all + all + ;; member matching + (and member (registry--match :member v member)) + ;; regex matching + (and regex (registry--match :regex v regex))) + collect k)))) + +(cl-defmethod registry-delete ((db registry-db) keys assert &rest spec) + "Delete KEYS from the registry-db THIS. +If KEYS is nil, use SPEC to do a search. +Updates the secondary ('tracked') indices as well. +With assert non-nil, errors out if the key does not exist already." + (let* ((data (oref db data)) + (keys (or keys + (apply 'registry-search db spec))) + (tracked (oref db tracked))) + + (dolist (key keys) + (let ((entry (gethash key data))) + (when assert + (cl-assert entry nil "Key %s does not exist in database" key)) + ;; clean entry from the secondary indices + (dolist (tr tracked) + ;; is this tracked symbol indexed? + (when (registry-lookup-secondary db tr) + ;; for every value in the entry under that key... + (dolist (val (cdr-safe (assq tr entry))) + (let* ((value-keys (registry-lookup-secondary-value + db tr val))) + (when (member key value-keys) + ;; override the previous value + (registry-lookup-secondary-value + db tr val + ;; with the indexed keys MINUS the current key + ;; (we pass t when the list is empty) + (or (delete key value-keys) t))))))) + (remhash key data))) + keys)) + +(cl-defmethod registry-size ((db registry-db)) + "Returns the size of the registry-db object THIS. +This is the key count of the `data' slot." + (hash-table-count (oref db data))) + +(cl-defmethod registry-full ((db registry-db)) + "Checks if registry-db THIS is full." + (>= (registry-size db) + (oref db max-size))) + +(cl-defmethod registry-insert ((db registry-db) key entry) + "Insert ENTRY under KEY into the registry-db THIS. +Updates the secondary ('tracked') indices as well. +Errors out if the key exists already." + (cl-assert (not (gethash key (oref db data))) nil + "Key already exists in database") + (cl-assert (not (registry-full db)) nil + "registry max-size limit reached") + + ;; store the entry + (puthash key entry (oref db data)) + + ;; store the secondary indices + (dolist (tr (oref db tracked)) + ;; for every value in the entry under that key... + (dolist (val (cdr-safe (assq tr entry))) + (let* ((value-keys (registry-lookup-secondary-value db tr val))) + (cl-pushnew key value-keys :test 'equal) + (registry-lookup-secondary-value db tr val value-keys)))) + entry) + +(cl-defmethod registry-reindex ((db registry-db)) + "Rebuild the secondary indices of registry-db THIS." + (let ((count 0) + (expected (* (length (oref db tracked)) (registry-size db)))) + (dolist (tr (oref db tracked)) + (let (values) + (maphash + (lambda (key v) + (cl-incf count) + (when (and (< 0 expected) + (= 0 (mod count 1000))) + (message "reindexing: %d of %d (%.2f%%)" + count expected (/ (* 100.0 count) expected))) + (dolist (val (cdr-safe (assq tr v))) + (let* ((value-keys (registry-lookup-secondary-value db tr val))) + (push key value-keys) + (registry-lookup-secondary-value db tr val value-keys)))) + (oref db data)))))) + +(cl-defmethod registry-prune ((db registry-db) &optional sortfunc) + "Prunes the registry-db object DB. + +Attempts to prune the number of entries down to \(* +:max-size :prune-factor) less than the max-size limit, so +pruning doesn't need to happen on every save. Removes only +entries without the :precious keys, so it may not be possible to +reach the target limit. + +Entries to be pruned are first sorted using SORTFUNC. Entries +from the front of the list are deleted first. + +Returns the number of deleted entries." + (let ((size (registry-size db)) + (target-size + (floor (- (oref db max-size) + (* (oref db max-size) + (oref db prune-factor))))) + candidates) + (if (registry-full db) + (progn + (setq candidates + (registry-collect-prune-candidates + db (- size target-size) sortfunc)) + (length (registry-delete db candidates nil))) + 0))) + +(cl-defmethod registry-collect-prune-candidates ((db registry-db) + limit sortfunc) + "Collects pruning candidates from the registry-db object DB. + +Proposes only entries without the :precious keys, and attempts to +return LIMIT such candidates. If SORTFUNC is provided, sort +entries first and return candidates from beginning of list." + (let* ((precious (oref db precious)) + (precious-p (lambda (entry-key) + (cdr (memq (car entry-key) precious)))) + (data (oref db data)) + (candidates (cl-loop for k being the hash-keys of data + using (hash-values v) + when (cl-notany precious-p v) + collect (cons k v)))) + ;; We want the full entries for sorting, but should only return a + ;; list of entry keys. + (when sortfunc + (setq candidates (sort candidates sortfunc))) + (cl-subseq (mapcar #'car candidates) 0 (min limit (length candidates))))) + +(provide 'registry) +;;; registry.el ends here diff --cc lisp/replace.el index a1721746330,752f3bdebf7..ff917344453 --- a/lisp/replace.el +++ b/lisp/replace.el @@@ -1,6 -1,6 +1,6 @@@ -;;; replace.el --- replace commands for Emacs +;;; replace.el --- replace commands for Emacs -*- lexical-binding: t -*- - ;; Copyright (C) 1985-1987, 1992, 1994, 1996-1997, 2000-2016 Free + ;; Copyright (C) 1985-1987, 1992, 1994, 1996-1997, 2000-2017 Free ;; Software Foundation, Inc. ;; Maintainer: emacs-devel@gnu.org diff --cc lisp/rot13.el index d0e4048ad61,c3aa3a91b01..20a0dbed462 --- a/lisp/rot13.el +++ b/lisp/rot13.el @@@ -1,6 -1,6 +1,6 @@@ -;;; rot13.el --- display a buffer in ROT13 +;;; rot13.el --- display a buffer in ROT13 -*- lexical-binding: t -*- - ;; Copyright (C) 1988, 2001-2016 Free Software Foundation, Inc. + ;; Copyright (C) 1988, 2001-2017 Free Software Foundation, Inc. ;; Author: Howard Gayle ;; Maintainer: emacs-devel@gnu.org diff --cc lisp/rtree.el index 662e043669a,00000000000..b4c9d48b83c mode 100644,000000..100644 --- a/lisp/rtree.el +++ b/lisp/rtree.el @@@ -1,281 -1,0 +1,281 @@@ +;;; rtree.el --- functions for manipulating range trees + - ;; Copyright (C) 2010-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2010-2017 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; A "range tree" is a binary tree that stores ranges. They are +;; similar to interval trees, but do not allow overlapping intervals. + +;; A range is an ordered list of number intervals, like this: + +;; ((10 . 25) 56 78 (98 . 201)) + +;; Common operations, like lookup, deletion and insertion are O(n) in +;; a range, but an rtree is O(log n) in all these operations. +;; Transformation between a range and an rtree is O(n). + +;; The rtrees are quite simple. The structure of each node is + +;; (cons (cons low high) (cons left right)) + +;; That is, they are three cons cells, where the car of the top cell +;; is the actual range, and the cdr has the left and right child. The +;; rtrees aren't automatically balanced, but are balanced when +;; created, and can be rebalanced when deemed necessary. + +;;; Code: + +(eval-when-compile + (require 'cl)) + +(defmacro rtree-make-node () + `(list (list nil) nil)) + +(defmacro rtree-set-left (node left) + `(setcar (cdr ,node) ,left)) + +(defmacro rtree-set-right (node right) + `(setcdr (cdr ,node) ,right)) + +(defmacro rtree-set-range (node range) + `(setcar ,node ,range)) + +(defmacro rtree-low (node) + `(caar ,node)) + +(defmacro rtree-high (node) + `(cdar ,node)) + +(defmacro rtree-set-low (node number) + `(setcar (car ,node) ,number)) + +(defmacro rtree-set-high (node number) + `(setcdr (car ,node) ,number)) + +(defmacro rtree-left (node) + `(cadr ,node)) + +(defmacro rtree-right (node) + `(cddr ,node)) + +(defmacro rtree-range (node) + `(car ,node)) + +(defsubst rtree-normalize-range (range) + (when (numberp range) + (setq range (cons range range))) + range) + +(define-obsolete-function-alias 'rtree-normalise-range + 'rtree-normalize-range "25.1") + +(defun rtree-make (range) + "Make an rtree from RANGE." + ;; Normalize the range. + (unless (listp (cdr-safe range)) + (setq range (list range))) + (rtree-make-1 (cons nil range) (length range))) + +(defun rtree-make-1 (range length) + (let ((mid (/ length 2)) + (node (rtree-make-node))) + (when (> mid 0) + (rtree-set-left node (rtree-make-1 range mid))) + (rtree-set-range node (rtree-normalize-range (cadr range))) + (setcdr range (cddr range)) + (when (> (- length mid 1) 0) + (rtree-set-right node (rtree-make-1 range (- length mid 1)))) + node)) + +(defun rtree-memq (tree number) + "Return non-nil if NUMBER is present in TREE." + (while (and tree + (not (and (>= number (rtree-low tree)) + (<= number (rtree-high tree))))) + (setq tree + (if (< number (rtree-low tree)) + (rtree-left tree) + (rtree-right tree)))) + tree) + +(defun rtree-add (tree number) + "Add NUMBER to TREE." + (while tree + (cond + ;; It's already present, so we don't have to do anything. + ((and (>= number (rtree-low tree)) + (<= number (rtree-high tree))) + (setq tree nil)) + ((< number (rtree-low tree)) + (cond + ;; Extend the low range. + ((= number (1- (rtree-low tree))) + (rtree-set-low tree number) + ;; Check whether we need to merge this node with the child. + (when (and (rtree-left tree) + (= (rtree-high (rtree-left tree)) (1- number))) + ;; Extend the range to the low from the child. + (rtree-set-low tree (rtree-low (rtree-left tree))) + ;; The child can't have a right child, so just transplant the + ;; child's left tree to our left tree. + (rtree-set-left tree (rtree-left (rtree-left tree)))) + (setq tree nil)) + ;; Descend further to the left. + ((rtree-left tree) + (setq tree (rtree-left tree))) + ;; Add a new node. + (t + (let ((new-node (rtree-make-node))) + (rtree-set-low new-node number) + (rtree-set-high new-node number) + (rtree-set-left tree new-node) + (setq tree nil))))) + (t + (cond + ;; Extend the high range. + ((= number (1+ (rtree-high tree))) + (rtree-set-high tree number) + ;; Check whether we need to merge this node with the child. + (when (and (rtree-right tree) + (= (rtree-low (rtree-right tree)) (1+ number))) + ;; Extend the range to the high from the child. + (rtree-set-high tree (rtree-high (rtree-right tree))) + ;; The child can't have a left child, so just transplant the + ;; child's left right to our right tree. + (rtree-set-right tree (rtree-right (rtree-right tree)))) + (setq tree nil)) + ;; Descend further to the right. + ((rtree-right tree) + (setq tree (rtree-right tree))) + ;; Add a new node. + (t + (let ((new-node (rtree-make-node))) + (rtree-set-low new-node number) + (rtree-set-high new-node number) + (rtree-set-right tree new-node) + (setq tree nil)))))))) + +(defun rtree-delq (tree number) + "Remove NUMBER from TREE destructively. Returns the new tree." + (let ((result tree) + prev) + (while tree + (cond + ((< number (rtree-low tree)) + (setq prev tree + tree (rtree-left tree))) + ((> number (rtree-high tree)) + (setq prev tree + tree (rtree-right tree))) + ;; The number is in this node. + (t + (cond + ;; The only entry; delete the node. + ((= (rtree-low tree) (rtree-high tree)) + (cond + ;; Two children. Replace with successor value. + ((and (rtree-left tree) (rtree-right tree)) + (let ((parent tree) + (successor (rtree-right tree))) + (while (rtree-left successor) + (setq parent successor + successor (rtree-left successor))) + ;; We now have the leftmost child of our right child. + (rtree-set-range tree (rtree-range successor)) + ;; Transplant the child (if any) to the parent. + (rtree-set-left parent (rtree-right successor)))) + (t + (let ((rest (or (rtree-left tree) + (rtree-right tree)))) + ;; One or zero children. Remove the node. + (cond + ((null prev) + (setq result rest)) + ((eq (rtree-left prev) tree) + (rtree-set-left prev rest)) + (t + (rtree-set-right prev rest))))))) + ;; The lowest in the range; just adjust. + ((= number (rtree-low tree)) + (rtree-set-low tree (1+ number))) + ;; The highest in the range; just adjust. + ((= number (rtree-high tree)) + (rtree-set-high tree (1- number))) + ;; We have to split this range. + (t + (let ((new-node (rtree-make-node))) + (rtree-set-low new-node (rtree-low tree)) + (rtree-set-high new-node (1- number)) + (rtree-set-low tree (1+ number)) + (cond + ;; Two children; insert the new node as the predecessor + ;; node. + ((and (rtree-left tree) (rtree-right tree)) + (let ((predecessor (rtree-left tree))) + (while (rtree-right predecessor) + (setq predecessor (rtree-right predecessor))) + (rtree-set-right predecessor new-node))) + ((rtree-left tree) + (rtree-set-right new-node tree) + (rtree-set-left new-node (rtree-left tree)) + (rtree-set-left tree nil) + (cond + ((null prev) + (setq result new-node)) + ((eq (rtree-left prev) tree) + (rtree-set-left prev new-node)) + (t + (rtree-set-right prev new-node)))) + (t + (rtree-set-left tree new-node)))))) + (setq tree nil)))) + result)) + +(defun rtree-extract (tree) + "Convert TREE to range form." + (let (stack result) + (while (or stack + tree) + (if tree + (progn + (push tree stack) + (setq tree (rtree-right tree))) + (setq tree (pop stack)) + (push (if (= (rtree-low tree) + (rtree-high tree)) + (rtree-low tree) + (rtree-range tree)) + result) + (setq tree (rtree-left tree)))) + result)) + +(defun rtree-length (tree) + "Return the number of numbers stored in TREE." + (if (null tree) + 0 + (+ (rtree-length (rtree-left tree)) + (1+ (- (rtree-high tree) + (rtree-low tree))) + (rtree-length (rtree-right tree))))) + +(provide 'rtree) + +;;; rtree.el ends here diff --cc lisp/ses.el index c80415e1e15,cf949ce55ce..76d4ca577d7 --- a/lisp/ses.el +++ b/lisp/ses.el @@@ -1,7 -1,6 +1,7 @@@ + ;;; ses.el -- Simple Emacs Spreadsheet -*- lexical-binding:t -*- - ;; Copyright (C) 2002-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2002-2017 Free Software Foundation, Inc. ;; Author: Jonathan Yavner ;; Maintainer: Vincent Belaïche diff --cc lisp/sort.el index 7f8acfc9b83,1989bb28bad..88a784fbb85 --- a/lisp/sort.el +++ b/lisp/sort.el @@@ -1,6 -1,6 +1,6 @@@ -;;; sort.el --- commands to sort text in an Emacs buffer +;;; sort.el --- commands to sort text in an Emacs buffer -*- lexical-binding: t -*- - ;; Copyright (C) 1986-1987, 1994-1995, 2001-2016 Free Software + ;; Copyright (C) 1986-1987, 1994-1995, 2001-2017 Free Software ;; Foundation, Inc. ;; Author: Howie Kaye diff --cc lisp/textmodes/ispell.el index 7551d2fde97,d9a1c7127ff..27ee5d372fd --- a/lisp/textmodes/ispell.el +++ b/lisp/textmodes/ispell.el @@@ -1,9 -1,14 +1,9 @@@ -;;; ispell.el --- interface to International Ispell Versions 3.1 and 3.2 +;;; ispell.el --- interface to International Ispell Versions 3.1 and 3.2 -*- lexical-binding:t -*- - ;; Copyright (C) 1994-1995, 1997-2016 Free Software Foundation, Inc. + ;; Copyright (C) 1994-1995, 1997-2017 Free Software Foundation, Inc. ;; Author: Ken Stevens -;; Maintainer: Ken Stevens -;; Stevens Mod Date: Mon Jan 7 12:32:44 PST 2003 -;; Stevens Revision: 3.6 ;; Status : Release with 3.1.12+ and 3.2.0+ ispell. -;; Bug Reports : ispell-el-bugs@itcorp.com -;; Web Site : http://kdstevens.com/~stevens/ispell-page.html ;; Keywords: unix wp ;; This file is part of GNU Emacs. diff --cc lisp/textmodes/rst.el index 7161dd329ac,0755d5fc813..90c1f4539d7 --- a/lisp/textmodes/rst.el +++ b/lisp/textmodes/rst.el @@@ -1,9 -1,9 +1,9 @@@ ;;; rst.el --- Mode for viewing and editing reStructuredText-documents. - ;; Copyright (C) 2003-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2003-2017 Free Software Foundation, Inc. -;; Maintainer: Stefan Merten -;; Author: Stefan Merten , +;; Maintainer: Stefan Merten +;; Author: Stefan Merten , ;; Martin Blais , ;; David Goodger , ;; Wei-Wei Guo diff --cc lisp/url/url-auth.el index a2aa97c2799,345aa135d99..7b6cdd53790 --- a/lisp/url/url-auth.el +++ b/lisp/url/url-auth.el @@@ -1,6 -1,6 +1,6 @@@ -;;; url-auth.el --- Uniform Resource Locator authorization modules +;;; url-auth.el --- Uniform Resource Locator authorization modules -*- lexical-binding: t -*- - ;; Copyright (C) 1996-1999, 2004-2016 Free Software Foundation, Inc. + ;; Copyright (C) 1996-1999, 2004-2017 Free Software Foundation, Inc. ;; Keywords: comm, data, processes, hypermedia diff --cc lisp/url/url-expand.el index 48d3ce40f74,54ae76cf7a1..cc9341bdf5f --- a/lisp/url/url-expand.el +++ b/lisp/url/url-expand.el @@@ -1,6 -1,6 +1,6 @@@ -;;; url-expand.el --- expand-file-name for URLs +;;; url-expand.el --- expand-file-name for URLs -*- lexical-binding: t -*- - ;; Copyright (C) 1999, 2004-2016 Free Software Foundation, Inc. + ;; Copyright (C) 1999, 2004-2017 Free Software Foundation, Inc. ;; Keywords: comm, data, processes diff --cc lisp/url/url-future.el index 12c971c87d6,c2fe3b94fbd..5394eb0e5ef --- a/lisp/url/url-future.el +++ b/lisp/url/url-future.el @@@ -1,6 -1,6 +1,6 @@@ -;;; url-future.el --- general futures facility for url.el +;;; url-future.el --- general futures facility for url.el -*- lexical-binding: t -*- - ;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2011-2017 Free Software Foundation, Inc. ;; Author: Teodor Zlatanov ;; Keywords: data diff --cc lisp/url/url-http.el index 81bb9b4721e,c5fb2ccd1fc..90f2e59cc5b --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@@ -1,6 -1,6 +1,6 @@@ -;;; url-http.el --- HTTP retrieval routines +;;; url-http.el --- HTTP retrieval routines -*- lexical-binding:t -*- - ;; Copyright (C) 1999, 2001, 2004-2016 Free Software Foundation, Inc. + ;; Copyright (C) 1999, 2001, 2004-2017 Free Software Foundation, Inc. ;; Author: Bill Perry ;; Maintainer: emacs-devel@gnu.org diff --cc lisp/url/url-parse.el index c0e386d0385,3bc5529824e..4738163f0bc --- a/lisp/url/url-parse.el +++ b/lisp/url/url-parse.el @@@ -1,6 -1,6 +1,6 @@@ -;;; url-parse.el --- Uniform Resource Locator parser +;;; url-parse.el --- Uniform Resource Locator parser -*- lexical-binding: t -*- - ;; Copyright (C) 1996-1999, 2004-2016 Free Software Foundation, Inc. + ;; Copyright (C) 1996-1999, 2004-2017 Free Software Foundation, Inc. ;; Keywords: comm, data, processes diff --cc lisp/url/url-queue.el index 8972d0b056c,3e8b85a5d0c..dd1699bd082 --- a/lisp/url/url-queue.el +++ b/lisp/url/url-queue.el @@@ -1,6 -1,6 +1,6 @@@ -;;; url-queue.el --- Fetching web pages in parallel +;;; url-queue.el --- Fetching web pages in parallel -*- lexical-binding: t -*- - ;; Copyright (C) 2011-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2011-2017 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: comm diff --cc lisp/url/url-util.el index a3844f9e32e,377c70edaf3..46d2d8ce5ff --- a/lisp/url/url-util.el +++ b/lisp/url/url-util.el @@@ -1,6 -1,6 +1,6 @@@ -;;; url-util.el --- Miscellaneous helper routines for URL library +;;; url-util.el --- Miscellaneous helper routines for URL library -*- lexical-binding: t -*- - ;; Copyright (C) 1996-1999, 2001, 2004-2016 Free Software Foundation, + ;; Copyright (C) 1996-1999, 2001, 2004-2017 Free Software Foundation, ;; Inc. ;; Author: Bill Perry diff --cc lisp/vc/ediff-util.el index 76223e9f6e4,26c284165b1..f81397950dd --- a/lisp/vc/ediff-util.el +++ b/lisp/vc/ediff-util.el @@@ -1,6 -1,6 +1,6 @@@ -;;; ediff-util.el --- the core commands and utilities of ediff +;;; ediff-util.el --- the core commands and utilities of ediff -*- lexical-binding:t -*- - ;; Copyright (C) 1994-2016 Free Software Foundation, Inc. + ;; Copyright (C) 1994-2017 Free Software Foundation, Inc. ;; Author: Michael Kifer ;; Package: ediff diff --cc lisp/wdired.el index f059ab774a5,76223215f2d..179b51b711a --- a/lisp/wdired.el +++ b/lisp/wdired.el @@@ -1,6 -1,6 +1,6 @@@ -;;; wdired.el --- Rename files editing their names in dired buffers +;;; wdired.el --- Rename files editing their names in dired buffers -*- coding: utf-8; -*- - ;; Copyright (C) 2004-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2004-2017 Free Software Foundation, Inc. ;; Filename: wdired.el ;; Author: Juan León Lahoz García diff --cc lisp/window.el index fdb67ed4a87,1c845f4ee99..358d7bc58f0 --- a/lisp/window.el +++ b/lisp/window.el @@@ -1,6 -1,6 +1,6 @@@ -;;; window.el --- GNU Emacs window commands aside from those written in C +;;; window.el --- GNU Emacs window commands aside from those written in C -*- lexical-binding:t -*- - ;; Copyright (C) 1985, 1989, 1992-1994, 2000-2016 Free Software + ;; Copyright (C) 1985, 1989, 1992-1994, 2000-2017 Free Software ;; Foundation, Inc. ;; Maintainer: emacs-devel@gnu.org diff --cc lisp/xml.el index 2563c13094f,844da5605bb..cd801be3083 --- a/lisp/xml.el +++ b/lisp/xml.el @@@ -1,6 -1,6 +1,6 @@@ -;;; xml.el --- XML parser +;;; xml.el --- XML parser -*- lexical-binding: t -*- - ;; Copyright (C) 2000-2016 Free Software Foundation, Inc. + ;; Copyright (C) 2000-2017 Free Software Foundation, Inc. ;; Author: Emmanuel Briot ;; Maintainer: Mark A. Hershberger diff --cc lisp/xt-mouse.el index d2d0cf5ee06,33307c73cac..acb30187a8e --- a/lisp/xt-mouse.el +++ b/lisp/xt-mouse.el @@@ -1,6 -1,6 +1,6 @@@ -;;; xt-mouse.el --- support the mouse when emacs run in an xterm +;;; xt-mouse.el --- support the mouse when emacs run in an xterm -*- lexical-binding: t -*- - ;; Copyright (C) 1994, 2000-2016 Free Software Foundation, Inc. + ;; Copyright (C) 1994, 2000-2017 Free Software Foundation, Inc. ;; Author: Per Abrahamsen ;; Keywords: mouse, terminals diff --cc m4/extensions.m4 index e114a6f7290,f7243b6b433..c60f537db17 --- a/m4/extensions.m4 +++ b/m4/extensions.m4 @@@ -1,7 -1,7 +1,7 @@@ -# serial 13 -*- Autoconf -*- +# serial 15 -*- Autoconf -*- # Enable extensions on systems that normally disable them. - # Copyright (C) 2003, 2006-2016 Free Software Foundation, Inc. + # Copyright (C) 2003, 2006-2017 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --cc m4/fpending.m4 index f6776a83e69,e37e0485f78..3a5e934c251 --- a/m4/fpending.m4 +++ b/m4/fpending.m4 @@@ -1,6 -1,6 +1,6 @@@ -# serial 21 +# serial 22 - # Copyright (C) 2000-2001, 2004-2016 Free Software Foundation, Inc. + # Copyright (C) 2000-2001, 2004-2017 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --cc nt/README.W32 index 9bc8f87496e,37183539f87..644e0fe881a --- a/nt/README.W32 +++ b/nt/README.W32 @@@ -1,7 -1,7 +1,7 @@@ - Copyright (C) 2001-2016 Free Software Foundation, Inc. + Copyright (C) 2001-2017 Free Software Foundation, Inc. See the end of the file for license conditions. - Emacs version 25.1.91 for MS-Windows + Emacs version 25.1.50 for MS-Windows This README file describes how to set up and run a precompiled distribution of the latest version of GNU Emacs for MS-Windows. You diff --cc test/Makefile.in index f2f27634c24,00000000000..5849e9c3ac9 mode 100644,000000..100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@@ -1,213 -1,0 +1,213 @@@ +### @configure_input@ + - # Copyright (C) 2010-2016 Free Software Foundation, Inc. ++# Copyright (C) 2010-2017 Free Software Foundation, Inc. + +# This file is part of GNU Emacs. + +# GNU Emacs is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. + +# GNU Emacs is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with GNU Emacs. If not, see . + +### Commentary: + +## Some targets: +## check: re-run all tests, writing to .log files. +## check-maybe: run all tests which are outdated with their .log file +## or the source files they are testing. +## filename.log: run tests from filename.el(c) if .log file needs updating +## filename: re-run tests from filename.el(c), with no logging + +### Code: + +SHELL = @SHELL@ + +srcdir = @srcdir@ +VPATH = $(srcdir) + +MKDIR_P = @MKDIR_P@ + +SEPCHAR = @SEPCHAR@ + +# We never change directory before running Emacs, so a relative file +# name is fine, and makes life easier. If we need to change +# directory, we can use emacs --chdir. +EMACS = ../src/emacs + +EMACS_EXTRAOPT= + +# Command line flags for Emacs. +# Apparently MSYS bash would convert "-L :" to "-L ;" anyway, +# but we might as well be explicit. +EMACSOPT = -batch --no-site-file --no-site-lisp -L "$(SEPCHAR)$(srcdir)" $(EMACS_EXTRAOPT) + +# Prevent any settings in the user environment causing problems. +unexport EMACSDATA EMACSDOC EMACSPATH GREP_OPTIONS + +## To run tests under a debugger, set this to eg: "gdb --args". +GDB = + +# The locale to run tests under. Tests should work if this is set to +# any supported locale. Use the C locale by default, as it should be +# supported everywhere. +TEST_LOCALE = C + +# The actual Emacs command run in the targets below. +# Prevent any setting of EMACSLOADPATH in user environment causing problems. +emacs = EMACSLOADPATH= LC_ALL=$(TEST_LOCALE) EMACS_TEST_DIRECTORY=$(srcdir) \ + $(GDB) "$(EMACS)" $(EMACSOPT) + +.PHONY: all check + +all: check + +%.elc: %.el + @echo Compiling $< + @$(emacs) -f batch-byte-compile $< + +## Ignore any test errors so we can continue to test other files. +## But compilation errors are always fatal. +WRITE_LOG = > $@ 2>&1 || { stat=ERROR; cat $@; }; echo $$stat: $@ + +## I'd prefer to use -emacs -f ert-run-tests-batch-and-exit rather +## than || true, since the former makes problems more obvious. +## I'd also prefer to @-hide the grep part and not the +## ert-run-tests-batch-and-exit part. +## +## We need to use $loadfile because: +## i) -L :$srcdir -l basename does not work, because we have files whose +## basename duplicates a file in lisp/ (eg eshell.el). +## ii) Although -l basename will automatically load .el or .elc, +## -l ./basename treats basename as a literal file (it would be nice +## to change this; bug#17848 - if that gets done, this can be simplified). +## +## Beware: it approximates 'no-byte-compile', so watch out for false-positives! +SELECTOR_DEFAULT = (quote (not (tag :expensive-test))) +SELECTOR_EXPENSIVE = nil +ifdef SELECTOR +SELECTOR_ACTUAL=$(SELECTOR) +else ifndef MAKECMDGOALS +SELECTOR_ACTUAL=$(SELECTOR_DEFAULT) +else ifeq ($(MAKECMDGOALS),all) +SELECTOR_ACTUAL=$(SELECTOR_DEFAULT) +else ifeq ($(MAKECMDGOALS),check) +SELECTOR_ACTUAL=$(SELECTOR_DEFAULT) +else ifeq ($(MAKECMDGOALS),check-maybe) +SELECTOR_ACTUAL=$(SELECTOR_DEFAULT) +else +SELECTOR_ACTUAL=$(SELECTOR_EXPENSIVE) +endif + +## Byte-compile all test files to test for errors (unless explicitly +## told not to), but then evaluate the un-byte-compiled files, because +## they give cleaner stacktraces. + +## Beware: it approximates 'no-byte-compile', so watch out for false-positives! +%.log: %.el + elc=$ /dev/null; then \ + ${MAKE} $$elc; \ + fi; \ + loadfile=$<; \ + echo Testing $$loadfile; \ + stat=OK ; \ + ${MKDIR_P} $(dir $@) ; \ + $(emacs) -l ert -l $$loadfile \ + --eval "(ert-run-tests-batch-and-exit ${SELECTOR_ACTUAL})" ${WRITE_LOG} + +ELFILES = $(shell find ${srcdir} -path "${srcdir}/manual" -prune -o \ + -path "*resources" -prune -o -name "*el" -print) +## .elc files may be in a different directory for out of source builds +ELCFILES = $(patsubst %.el,%.elc, \ + $(patsubst $(srcdir)%,.%,$(ELFILES))) +LOGFILES = $(patsubst %.elc,%.log,${ELCFILES}) +LOGSAVEFILES = $(patsubst %.elc,%.log~,${ELCFILES}) +TESTS = $(subst ${srcdir}/,,$(LOGFILES:.log=)) + +## If we have to interrupt a hanging test, preserve the log so we can +## see what the problem was. +.PRECIOUS: %.log + +.PHONY: ${TESTS} + +## The short aliases that always re-run the tests, with no logging. +## Define an alias both with and without the directory name for ease +## of use. +define test_template +$(1): + @test ! -f ./$(1).log || mv ./$(1).log ./$(1).log~ + @${MAKE} ./$(1).log WRITE_LOG= + +$(notdir $(1)): $(1) +endef + +$(foreach test,${TESTS},$(eval $(call test_template,${test}))) + +## Check that there is no 'automated' subdirectory, which would +## indicate an incomplete merge from an older version of Emacs where +## the tests were arranged differently. +.PHONY: check-no-automated-subdir +check-no-automated-subdir: + test ! -d $(srcdir)/automated + +## Include dependencies between test files and the files they test. +## We could do this without the file and eval directly, but then we +## would have to run Emacs for every make invocation, and it might not +## be available during clean. +-include make-test-deps.mk +## Rerun all default tests. +check: mostlyclean check-no-automated-subdir + @${MAKE} check-doit SELECTOR="${SELECTOR_ACTUAL}" + +## Rerun all default and expensive tests. +.PHONY: check-expensive +check-expensive: mostlyclean check-no-automated-subdir + @${MAKE} check-doit SELECTOR="${SELECTOR_EXPENSIVE}" + +## Re-run all tests which are outdated. A test is outdated if its +## logfile is out-of-date with either the test file, or the source +## files that the tests depend on. The source file dependencies are +## determined by a heuristic and does not identify the full dependency +## graph. See make-test-deps.emacs-lisp for details. +.PHONY: check-maybe +check-maybe: check-no-automated-subdir + @${MAKE} check-doit SELECTOR="${SELECTOR_ACTUAL}" + +## Run the tests. +.PHONY: check-doit +check-doit: ${LOGFILES} + $(emacs) -l ert -f ert-summarize-tests-batch-and-exit $^ + +.PHONY: mostlyclean clean bootstrap-clean distclean maintainer-clean + +mostlyclean: + -@for f in ${LOGFILES}; do test ! -f $$f || mv $$f $$f~; done + rm -f *.tmp + +clean: + -rm -f ${LOGFILES} ${LOGSAVEFILES} + -rm make-test-deps.mk + +bootstrap-clean: clean + -rm -f ${ELCFILES} + +distclean: clean + rm -f Makefile + +maintainer-clean: distclean bootstrap-clean + +make-test-deps.mk: $(ELFILES) make-test-deps.emacs-lisp + $(EMACS) --batch -l $(srcdir)/make-test-deps.emacs-lisp \ + --eval "(make-test-deps \"$(srcdir)\")" \ + 2> $@.tmp + # Hack to elide any CANNOT_DUMP=yes chatter. + sed '/\.log: /!d' $@.tmp >$@ + rm -f $@.tmp diff --cc test/automated/tramp-tests.el index 00000000000,83a780d9906..10e1bde51e7 mode 000000,100644..100644 --- a/test/automated/tramp-tests.el +++ b/test/automated/tramp-tests.el @@@ -1,0 -1,2383 +1,2383 @@@ + ;;; tramp-tests.el --- Tests of remote file access + + ;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + + ;; Author: Michael Albinus + + ;; This program is free software: you can redistribute it and/or + ;; modify it under the terms of the GNU General Public License as + ;; published by the Free Software Foundation, either version 3 of the + ;; License, or (at your option) any later version. + ;; + ;; This program is distributed in the hope that it will be useful, but + ;; WITHOUT ANY WARRANTY; without even the implied warranty of + ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + ;; General Public License for more details. + ;; + ;; You should have received a copy of the GNU General Public License + ;; along with this program. If not, see `http://www.gnu.org/licenses/'. + + ;;; Commentary: + + ;; The tests require a recent ert.el from Emacs 24.4. + + ;; Some of the tests require access to a remote host files. Since + ;; this could be problematic, a mock-up connection method "mock" is + ;; used. Emulating a remote connection, it simply calls "sh -i". + ;; Tramp's file name handlers still run, so this test is sufficient + ;; except for connection establishing. + + ;; If you want to test a real Tramp connection, set + ;; $REMOTE_TEMPORARY_FILE_DIRECTORY to a suitable value in order to + ;; overwrite the default value. If you want to skip tests accessing a + ;; remote host, set this environment variable to "/dev/null" or + ;; whatever is appropriate on your system. + + ;; A whole test run can be performed calling the command `tramp-test-all'. + + ;;; Code: + + (require 'ert) + (require 'tramp) + (require 'vc) + (require 'vc-bzr) + (require 'vc-git) + (require 'vc-hg) + + (autoload 'dired-uncache "dired") + (declare-function tramp-find-executable "tramp-sh") + (declare-function tramp-get-remote-path "tramp-sh") + (declare-function tramp-get-remote-stat "tramp-sh") + (declare-function tramp-get-remote-perl "tramp-sh") + (defvar tramp-copy-size-limit) + (defvar tramp-persistency-file-name) + (defvar tramp-remote-process-environment) + + ;; There is no default value on w32 systems, which could work out of the box. + (defconst tramp-test-temporary-file-directory + (cond + ((getenv "REMOTE_TEMPORARY_FILE_DIRECTORY")) + ((eq system-type 'windows-nt) null-device) + (t (add-to-list + 'tramp-methods + '("mock" + (tramp-login-program "sh") + (tramp-login-args (("-i"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10))) + (format "/mock::%s" temporary-file-directory))) + "Temporary directory for Tramp tests.") + + (setq password-cache-expiry nil + tramp-verbose 0 + tramp-copy-size-limit nil + tramp-message-show-message nil + tramp-persistency-file-name nil) + + ;; This shall happen on hydra only. + (when (getenv "NIX_STORE") + (add-to-list 'tramp-remote-path 'tramp-own-remote-path)) + + (defvar tramp--test-enabled-checked nil + "Cached result of `tramp--test-enabled'. + If the function did run, the value is a cons cell, the `cdr' + being the result.") + + (defun tramp--test-enabled () + "Whether remote file access is enabled." + (unless (consp tramp--test-enabled-checked) + (setq + tramp--test-enabled-checked + (cons + t (ignore-errors + (and + (file-remote-p tramp-test-temporary-file-directory) + (file-directory-p tramp-test-temporary-file-directory) + (file-writable-p tramp-test-temporary-file-directory)))))) + + (when (cdr tramp--test-enabled-checked) + ;; Cleanup connection. + (ignore-errors + (tramp-cleanup-connection + (tramp-dissect-file-name tramp-test-temporary-file-directory) + nil 'keep-password))) + + ;; Return result. + (cdr tramp--test-enabled-checked)) + + (defun tramp--test-make-temp-name (&optional local) + "Create a temporary file name for test." + (expand-file-name + (make-temp-name "tramp-test") + (if local temporary-file-directory tramp-test-temporary-file-directory))) + + (defmacro tramp--instrument-test-case (verbose &rest body) + "Run BODY with `tramp-verbose' equal VERBOSE. + Print the the content of the Tramp debug buffer, if BODY does not + eval properly in `should', `should-not' or `should-error'. BODY + shall not contain a timeout." + (declare (indent 1) (debug (natnump body))) + `(let ((tramp-verbose ,verbose) + (tramp-message-show-message t) + (tramp-debug-on-error t) + (debug-ignored-errors + (cons "^make-symbolic-link not supported$" debug-ignored-errors))) + (unwind-protect + (progn ,@body) + (when (> tramp-verbose 3) + (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil + (with-current-buffer (tramp-get-connection-buffer v) + (message "%s" (buffer-string))) + (with-current-buffer (tramp-get-debug-buffer v) + (message "%s" (buffer-string)))))))) + + (ert-deftest tramp-test00-availability () + "Test availability of Tramp functions." + :expected-result (if (tramp--test-enabled) :passed :failed) + (message "Remote directory: `%s'" tramp-test-temporary-file-directory) + (should (ignore-errors + (and + (file-remote-p tramp-test-temporary-file-directory) + (file-directory-p tramp-test-temporary-file-directory) + (file-writable-p tramp-test-temporary-file-directory))))) + + (ert-deftest tramp-test01-file-name-syntax () + "Check remote file name syntax." + ;; Simple cases. + (should (tramp-tramp-file-p "/method::")) + (should (tramp-tramp-file-p "/host:")) + (should (tramp-tramp-file-p "/user@:")) + (should (tramp-tramp-file-p "/user@host:")) + (should (tramp-tramp-file-p "/method:host:")) + (should (tramp-tramp-file-p "/method:user@:")) + (should (tramp-tramp-file-p "/method:user@host:")) + (should (tramp-tramp-file-p "/method:user@email@host:")) + + ;; Using a port. + (should (tramp-tramp-file-p "/host#1234:")) + (should (tramp-tramp-file-p "/user@host#1234:")) + (should (tramp-tramp-file-p "/method:host#1234:")) + (should (tramp-tramp-file-p "/method:user@host#1234:")) + + ;; Using an IPv4 address. + (should (tramp-tramp-file-p "/1.2.3.4:")) + (should (tramp-tramp-file-p "/user@1.2.3.4:")) + (should (tramp-tramp-file-p "/method:1.2.3.4:")) + (should (tramp-tramp-file-p "/method:user@1.2.3.4:")) + + ;; Using an IPv6 address. + (should (tramp-tramp-file-p "/[]:")) + (should (tramp-tramp-file-p "/[::1]:")) + (should (tramp-tramp-file-p "/user@[::1]:")) + (should (tramp-tramp-file-p "/method:[::1]:")) + (should (tramp-tramp-file-p "/method:user@[::1]:")) + + ;; Local file name part. + (should (tramp-tramp-file-p "/host:/:")) + (should (tramp-tramp-file-p "/method:::")) + (should (tramp-tramp-file-p "/method::/path/to/file")) + (should (tramp-tramp-file-p "/method::file")) + + ;; Multihop. + (should (tramp-tramp-file-p "/method1:|method2::")) + (should (tramp-tramp-file-p "/method1:host1|host2:")) + (should (tramp-tramp-file-p "/method1:host1|method2:host2:")) + (should (tramp-tramp-file-p "/method1:user1@host1|method2:user2@host2:")) + (should (tramp-tramp-file-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:")) + + ;; No strings. + (should-not (tramp-tramp-file-p nil)) + (should-not (tramp-tramp-file-p 'symbol)) + ;; "/:" suppresses file name handlers. + (should-not (tramp-tramp-file-p "/::")) + (should-not (tramp-tramp-file-p "/:@:")) + (should-not (tramp-tramp-file-p "/:[]:")) + ;; Multihops require a method. + (should-not (tramp-tramp-file-p "/host1|host2:")) + ;; Methods or hostnames shall be at least two characters on MS Windows. + (when (memq system-type '(cygwin windows-nt)) + (should-not (tramp-tramp-file-p "/c:/path/to/file")) + (should-not (tramp-tramp-file-p "/c::/path/to/file")))) + + (ert-deftest tramp-test02-file-name-dissect () + "Check remote file name components." + (let ((tramp-default-method "default-method") + (tramp-default-user "default-user") + (tramp-default-host "default-host")) + ;; Expand `tramp-default-user' and `tramp-default-host'. + (should (string-equal + (file-remote-p "/method::") + (format "/%s:%s@%s:" "method" "default-user" "default-host"))) + (should (string-equal (file-remote-p "/method::" 'method) "method")) + (should (string-equal (file-remote-p "/method::" 'user) "default-user")) + (should (string-equal (file-remote-p "/method::" 'host) "default-host")) + (should (string-equal (file-remote-p "/method::" 'localname) "")) + (should (string-equal (file-remote-p "/method::" 'hop) nil)) + + ;; Expand `tramp-default-method' and `tramp-default-user'. + (should (string-equal + (file-remote-p "/host:") + (format "/%s:%s@%s:" "default-method" "default-user" "host"))) + (should (string-equal (file-remote-p "/host:" 'method) "default-method")) + (should (string-equal (file-remote-p "/host:" 'user) "default-user")) + (should (string-equal (file-remote-p "/host:" 'host) "host")) + (should (string-equal (file-remote-p "/host:" 'localname) "")) + (should (string-equal (file-remote-p "/host:" 'hop) nil)) + + ;; Expand `tramp-default-method' and `tramp-default-host'. + (should (string-equal + (file-remote-p "/user@:") + (format "/%s:%s@%s:" "default-method""user" "default-host"))) + (should (string-equal (file-remote-p "/user@:" 'method) "default-method")) + (should (string-equal (file-remote-p "/user@:" 'user) "user")) + (should (string-equal (file-remote-p "/user@:" 'host) "default-host")) + (should (string-equal (file-remote-p "/user@:" 'localname) "")) + (should (string-equal (file-remote-p "/user@:" 'hop) nil)) + + ;; Expand `tramp-default-method'. + (should (string-equal + (file-remote-p "/user@host:") + (format "/%s:%s@%s:" "default-method" "user" "host"))) + (should (string-equal + (file-remote-p "/user@host:" 'method) "default-method")) + (should (string-equal (file-remote-p "/user@host:" 'user) "user")) + (should (string-equal (file-remote-p "/user@host:" 'host) "host")) + (should (string-equal (file-remote-p "/user@host:" 'localname) "")) + (should (string-equal (file-remote-p "/user@host:" 'hop) nil)) + + ;; Expand `tramp-default-user'. + (should (string-equal + (file-remote-p "/method:host:") + (format "/%s:%s@%s:" "method" "default-user" "host"))) + (should (string-equal (file-remote-p "/method:host:" 'method) "method")) + (should (string-equal (file-remote-p "/method:host:" 'user) "default-user")) + (should (string-equal (file-remote-p "/method:host:" 'host) "host")) + (should (string-equal (file-remote-p "/method:host:" 'localname) "")) + (should (string-equal (file-remote-p "/method:host:" 'hop) nil)) + + ;; Expand `tramp-default-host'. + (should (string-equal + (file-remote-p "/method:user@:") + (format "/%s:%s@%s:" "method" "user" "default-host"))) + (should (string-equal (file-remote-p "/method:user@:" 'method) "method")) + (should (string-equal (file-remote-p "/method:user@:" 'user) "user")) + (should (string-equal (file-remote-p "/method:user@:" 'host) + "default-host")) + (should (string-equal (file-remote-p "/method:user@:" 'localname) "")) + (should (string-equal (file-remote-p "/method:user@:" 'hop) nil)) + + ;; No expansion. + (should (string-equal + (file-remote-p "/method:user@host:") + (format "/%s:%s@%s:" "method" "user" "host"))) + (should (string-equal + (file-remote-p "/method:user@host:" 'method) "method")) + (should (string-equal (file-remote-p "/method:user@host:" 'user) "user")) + (should (string-equal (file-remote-p "/method:user@host:" 'host) "host")) + (should (string-equal (file-remote-p "/method:user@host:" 'localname) "")) + (should (string-equal (file-remote-p "/method:user@host:" 'hop) nil)) + + ;; No expansion. + (should (string-equal + (file-remote-p "/method:user@email@host:") + (format "/%s:%s@%s:" "method" "user@email" "host"))) + (should (string-equal + (file-remote-p "/method:user@email@host:" 'method) "method")) + (should (string-equal + (file-remote-p "/method:user@email@host:" 'user) "user@email")) + (should (string-equal + (file-remote-p "/method:user@email@host:" 'host) "host")) + (should (string-equal + (file-remote-p "/method:user@email@host:" 'localname) "")) + (should (string-equal + (file-remote-p "/method:user@email@host:" 'hop) nil)) + + ;; Expand `tramp-default-method' and `tramp-default-user'. + (should (string-equal + (file-remote-p "/host#1234:") + (format "/%s:%s@%s:" "default-method" "default-user" "host#1234"))) + (should (string-equal + (file-remote-p "/host#1234:" 'method) "default-method")) + (should (string-equal (file-remote-p "/host#1234:" 'user) "default-user")) + (should (string-equal (file-remote-p "/host#1234:" 'host) "host#1234")) + (should (string-equal (file-remote-p "/host#1234:" 'localname) "")) + (should (string-equal (file-remote-p "/host#1234:" 'hop) nil)) + + ;; Expand `tramp-default-method'. + (should (string-equal + (file-remote-p "/user@host#1234:") + (format "/%s:%s@%s:" "default-method" "user" "host#1234"))) + (should (string-equal + (file-remote-p "/user@host#1234:" 'method) "default-method")) + (should (string-equal (file-remote-p "/user@host#1234:" 'user) "user")) + (should (string-equal (file-remote-p "/user@host#1234:" 'host) "host#1234")) + (should (string-equal (file-remote-p "/user@host#1234:" 'localname) "")) + (should (string-equal (file-remote-p "/user@host#1234:" 'hop) nil)) + + ;; Expand `tramp-default-user'. + (should (string-equal + (file-remote-p "/method:host#1234:") + (format "/%s:%s@%s:" "method" "default-user" "host#1234"))) + (should (string-equal + (file-remote-p "/method:host#1234:" 'method) "method")) + (should (string-equal + (file-remote-p "/method:host#1234:" 'user) "default-user")) + (should (string-equal + (file-remote-p "/method:host#1234:" 'host) "host#1234")) + (should (string-equal (file-remote-p "/method:host#1234:" 'localname) "")) + (should (string-equal (file-remote-p "/method:host#1234:" 'hop) nil)) + + ;; No expansion. + (should (string-equal + (file-remote-p "/method:user@host#1234:") + (format "/%s:%s@%s:" "method" "user" "host#1234"))) + (should (string-equal + (file-remote-p "/method:user@host#1234:" 'method) "method")) + (should (string-equal + (file-remote-p "/method:user@host#1234:" 'user) "user")) + (should (string-equal + (file-remote-p "/method:user@host#1234:" 'host) "host#1234")) + (should (string-equal + (file-remote-p "/method:user@host#1234:" 'localname) "")) + (should (string-equal + (file-remote-p "/method:user@host#1234:" 'hop) nil)) + + ;; Expand `tramp-default-method' and `tramp-default-user'. + (should (string-equal + (file-remote-p "/1.2.3.4:") + (format "/%s:%s@%s:" "default-method" "default-user" "1.2.3.4"))) + (should (string-equal (file-remote-p "/1.2.3.4:" 'method) "default-method")) + (should (string-equal (file-remote-p "/1.2.3.4:" 'user) "default-user")) + (should (string-equal (file-remote-p "/1.2.3.4:" 'host) "1.2.3.4")) + (should (string-equal (file-remote-p "/1.2.3.4:" 'localname) "")) + (should (string-equal (file-remote-p "/1.2.3.4:" 'hop) nil)) + + ;; Expand `tramp-default-method'. + (should (string-equal + (file-remote-p "/user@1.2.3.4:") + (format "/%s:%s@%s:" "default-method" "user" "1.2.3.4"))) + (should (string-equal + (file-remote-p "/user@1.2.3.4:" 'method) "default-method")) + (should (string-equal (file-remote-p "/user@1.2.3.4:" 'user) "user")) + (should (string-equal (file-remote-p "/user@1.2.3.4:" 'host) "1.2.3.4")) + (should (string-equal (file-remote-p "/user@1.2.3.4:" 'localname) "")) + (should (string-equal (file-remote-p "/user@1.2.3.4:" 'hop) nil)) + + ;; Expand `tramp-default-user'. + (should (string-equal + (file-remote-p "/method:1.2.3.4:") + (format "/%s:%s@%s:" "method" "default-user" "1.2.3.4"))) + (should (string-equal (file-remote-p "/method:1.2.3.4:" 'method) "method")) + (should (string-equal + (file-remote-p "/method:1.2.3.4:" 'user) "default-user")) + (should (string-equal (file-remote-p "/method:1.2.3.4:" 'host) "1.2.3.4")) + (should (string-equal (file-remote-p "/method:1.2.3.4:" 'localname) "")) + (should (string-equal (file-remote-p "/method:1.2.3.4:" 'hop) nil)) + + ;; No expansion. + (should (string-equal + (file-remote-p "/method:user@1.2.3.4:") + (format "/%s:%s@%s:" "method" "user" "1.2.3.4"))) + (should (string-equal + (file-remote-p "/method:user@1.2.3.4:" 'method) "method")) + (should (string-equal (file-remote-p "/method:user@1.2.3.4:" 'user) "user")) + (should (string-equal + (file-remote-p "/method:user@1.2.3.4:" 'host) "1.2.3.4")) + (should (string-equal + (file-remote-p "/method:user@1.2.3.4:" 'localname) "")) + (should (string-equal + (file-remote-p "/method:user@1.2.3.4:" 'hop) nil)) + + ;; Expand `tramp-default-method', `tramp-default-user' and + ;; `tramp-default-host'. + (should (string-equal + (file-remote-p "/[]:") + (format + "/%s:%s@%s:" "default-method" "default-user" "default-host"))) + (should (string-equal (file-remote-p "/[]:" 'method) "default-method")) + (should (string-equal (file-remote-p "/[]:" 'user) "default-user")) + (should (string-equal (file-remote-p "/[]:" 'host) "default-host")) + (should (string-equal (file-remote-p "/[]:" 'localname) "")) + (should (string-equal (file-remote-p "/[]:" 'hop) nil)) + + ;; Expand `tramp-default-method' and `tramp-default-user'. + (let ((tramp-default-host "::1")) + (should (string-equal + (file-remote-p "/[]:") + (format "/%s:%s@%s:" "default-method" "default-user" "[::1]"))) + (should (string-equal (file-remote-p "/[]:" 'method) "default-method")) + (should (string-equal (file-remote-p "/[]:" 'user) "default-user")) + (should (string-equal (file-remote-p "/[]:" 'host) "::1")) + (should (string-equal (file-remote-p "/[]:" 'localname) "")) + (should (string-equal (file-remote-p "/[]:" 'hop) nil))) + + ;; Expand `tramp-default-method' and `tramp-default-user'. + (should (string-equal + (file-remote-p "/[::1]:") + (format "/%s:%s@%s:" "default-method" "default-user" "[::1]"))) + (should (string-equal (file-remote-p "/[::1]:" 'method) "default-method")) + (should (string-equal (file-remote-p "/[::1]:" 'user) "default-user")) + (should (string-equal (file-remote-p "/[::1]:" 'host) "::1")) + (should (string-equal (file-remote-p "/[::1]:" 'localname) "")) + (should (string-equal (file-remote-p "/[::1]:" 'hop) nil)) + + ;; Expand `tramp-default-method'. + (should (string-equal + (file-remote-p "/user@[::1]:") + (format "/%s:%s@%s:" "default-method" "user" "[::1]"))) + (should (string-equal + (file-remote-p "/user@[::1]:" 'method) "default-method")) + (should (string-equal (file-remote-p "/user@[::1]:" 'user) "user")) + (should (string-equal (file-remote-p "/user@[::1]:" 'host) "::1")) + (should (string-equal (file-remote-p "/user@[::1]:" 'localname) "")) + (should (string-equal (file-remote-p "/user@[::1]:" 'hop) nil)) + + ;; Expand `tramp-default-user'. + (should (string-equal + (file-remote-p "/method:[::1]:") + (format "/%s:%s@%s:" "method" "default-user" "[::1]"))) + (should (string-equal (file-remote-p "/method:[::1]:" 'method) "method")) + (should (string-equal + (file-remote-p "/method:[::1]:" 'user) "default-user")) + (should (string-equal (file-remote-p "/method:[::1]:" 'host) "::1")) + (should (string-equal (file-remote-p "/method:[::1]:" 'localname) "")) + (should (string-equal (file-remote-p "/method:[::1]:" 'hop) nil)) + + ;; No expansion. + (should (string-equal + (file-remote-p "/method:user@[::1]:") + (format "/%s:%s@%s:" "method" "user" "[::1]"))) + (should (string-equal + (file-remote-p "/method:user@[::1]:" 'method) "method")) + (should (string-equal (file-remote-p "/method:user@[::1]:" 'user) "user")) + (should (string-equal (file-remote-p "/method:user@[::1]:" 'host) "::1")) + (should (string-equal + (file-remote-p "/method:user@[::1]:" 'localname) "")) + (should (string-equal (file-remote-p "/method:user@[::1]:" 'hop) nil)) + + ;; Local file name part. + (should (string-equal (file-remote-p "/host:/:" 'localname) "/:")) + (should (string-equal (file-remote-p "/method:::" 'localname) ":")) + (should (string-equal (file-remote-p "/method:: " 'localname) " ")) + (should (string-equal (file-remote-p "/method::file" 'localname) "file")) + (should (string-equal + (file-remote-p "/method::/path/to/file" 'localname) + "/path/to/file")) + + ;; Multihop. + (should + (string-equal + (file-remote-p "/method1:user1@host1|method2:user2@host2:/path/to/file") + (format "/%s:%s@%s|%s:%s@%s:" + "method1" "user1" "host1" "method2" "user2" "host2"))) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2:/path/to/file" 'method) + "method2")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2:/path/to/file" 'user) + "user2")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2:/path/to/file" 'host) + "host2")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2:/path/to/file" 'localname) + "/path/to/file")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2:/path/to/file" 'hop) + (format "%s:%s@%s|" + "method1" "user1" "host1"))) + + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:/path/to/file") + (format "/%s:%s@%s|%s:%s@%s|%s:%s@%s:" + "method1" "user1" "host1" + "method2" "user2" "host2" + "method3" "user3" "host3"))) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:/path/to/file" + 'method) + "method3")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:/path/to/file" + 'user) + "user3")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:/path/to/file" + 'host) + "host3")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:/path/to/file" + 'localname) + "/path/to/file")) + (should + (string-equal + (file-remote-p + "/method1:user1@host1|method2:user2@host2|method3:user3@host3:/path/to/file" + 'hop) + (format "%s:%s@%s|%s:%s@%s|" + "method1" "user1" "host1" "method2" "user2" "host2"))))) + + (ert-deftest tramp-test03-file-name-defaults () + "Check default values for some methods." + ;; Default values in tramp-adb.el. + (should (string-equal (file-remote-p "/adb::" 'host) "")) + ;; Default values in tramp-ftp.el. + (should (string-equal (file-remote-p "/ftp.host:" 'method) "ftp")) + (dolist (u '("ftp" "anonymous")) + (should (string-equal (file-remote-p (format "/%s@:" u) 'method) "ftp"))) + ;; Default values in tramp-gvfs.el. + (when (and (load "tramp-gvfs" 'noerror 'nomessage) + (symbol-value 'tramp-gvfs-enabled)) + (should (string-equal (file-remote-p "/synce::" 'user) nil))) + ;; Default values in tramp-gw.el. + (dolist (m '("tunnel" "socks")) + (should + (string-equal (file-remote-p (format "/%s::" m) 'user) (user-login-name)))) + ;; Default values in tramp-sh.el. + (dolist (h `("127.0.0.1" "[::1]" "localhost" "localhost6" ,(system-name))) + (should (string-equal (file-remote-p (format "/root@%s:" h) 'method) "su"))) + (dolist (m '("su" "sudo" "ksu")) + (should (string-equal (file-remote-p (format "/%s::" m) 'user) "root"))) + (dolist (m '("rcp" "remcp" "rsh" "telnet" "krlogin" "fcp")) + (should + (string-equal (file-remote-p (format "/%s::" m) 'user) (user-login-name)))) + ;; Default values in tramp-smb.el. + (should (string-equal (file-remote-p "/user%domain@host:" 'method) "smb")) + (should (string-equal (file-remote-p "/smb::" 'user) nil))) + + (ert-deftest tramp-test04-substitute-in-file-name () + "Check `substitute-in-file-name'." + (should (string-equal (substitute-in-file-name "/method:host://foo") "/foo")) + (should + (string-equal + (substitute-in-file-name "/method:host:/path//foo") "/method:host:/foo")) + (should + (string-equal (substitute-in-file-name "/method:host:/path///foo") "/foo")) + (should + (string-equal + (substitute-in-file-name "/method:host:/path/~/foo") "/method:host:~/foo")) + (should + (string-equal (substitute-in-file-name "/method:host:/path//~/foo") "~/foo")) + (let (process-environment) + (should + (string-equal + (substitute-in-file-name "/method:host:/path/$FOO") + "/method:host:/path/$FOO")) + (setenv "FOO" "bla") + (should + (string-equal + (substitute-in-file-name "/method:host:/path/$FOO") + "/method:host:/path/bla")) + (should + (string-equal + (substitute-in-file-name "/method:host:/path/$$FOO") + "/method:host:/path/$FOO")))) + + (ert-deftest tramp-test05-expand-file-name () + "Check `expand-file-name'." + (should + (string-equal + (expand-file-name "/method:host:/path/./file") "/method:host:/path/file")) + (should + (string-equal + (expand-file-name "/method:host:/path/../file") "/method:host:/file"))) + + (ert-deftest tramp-test06-directory-file-name () + "Check `directory-file-name'. + This checks also `file-name-as-directory', `file-name-directory', + `file-name-nondirectory' and `unhandled-file-name-directory'." + (should + (string-equal + (directory-file-name "/method:host:/path/to/file") + "/method:host:/path/to/file")) + (should + (string-equal + (directory-file-name "/method:host:/path/to/file/") + "/method:host:/path/to/file")) + (should + (string-equal + (file-name-as-directory "/method:host:/path/to/file") + "/method:host:/path/to/file/")) + (should + (string-equal + (file-name-as-directory "/method:host:/path/to/file/") + "/method:host:/path/to/file/")) + (should + (string-equal + (file-name-directory "/method:host:/path/to/file") + "/method:host:/path/to/")) + (should + (string-equal + (file-name-directory "/method:host:/path/to/file/") + "/method:host:/path/to/file/")) + (should + (string-equal (file-name-nondirectory "/method:host:/path/to/file") "file")) + (should + (string-equal (file-name-nondirectory "/method:host:/path/to/file/") "")) + (should-not + (unhandled-file-name-directory "/method:host:/path/to/file"))) + + (ert-deftest tramp-test07-file-exists-p () + "Check `file-exist-p', `write-region' and `delete-file'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + (should-not (file-exists-p tmp-name)) + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (delete-file tmp-name) + (should-not (file-exists-p tmp-name)))) + + (ert-deftest tramp-test08-file-local-copy () + "Check `file-local-copy'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name1 (tramp--test-make-temp-name)) + tmp-name2) + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (should (setq tmp-name2 (file-local-copy tmp-name1))) + (with-temp-buffer + (insert-file-contents tmp-name2) + (should (string-equal (buffer-string) "foo"))) + ;; Check also that a file transfer with compression works. + (let ((default-directory tramp-test-temporary-file-directory) + (tramp-copy-size-limit 4) + (tramp-inline-compress-start-size 2)) + (delete-file tmp-name2) + (should (setq tmp-name2 (file-local-copy tmp-name1))))) + + ;; Cleanup. + (ignore-errors + (delete-file tmp-name1) + (delete-file tmp-name2))))) + + (ert-deftest tramp-test09-insert-file-contents () + "Check `insert-file-contents'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + (unwind-protect + (progn + (write-region "foo" nil tmp-name) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foo")) + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foofoo")) + ;; Insert partly. + (insert-file-contents tmp-name nil 1 3) + (should (string-equal (buffer-string) "oofoofoo")) + ;; Replace. + (insert-file-contents tmp-name nil nil nil 'replace) + (should (string-equal (buffer-string) "foo")))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))))) + + (ert-deftest tramp-test10-write-region () + "Check `write-region'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + (unwind-protect + (progn + (with-temp-buffer + (insert "foo") + (write-region nil nil tmp-name)) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foo"))) + ;; Append. + (with-temp-buffer + (insert "bla") + (write-region nil nil tmp-name 'append)) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foobla"))) + ;; Write string. + (write-region "foo" nil tmp-name) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foo"))) + ;; Write partly. - (with-temp-buffer ++ (with-temp-buffer + (insert "123456789") + (write-region 3 5 tmp-name)) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "34")))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))))) + + (ert-deftest tramp-test11-copy-file () + "Check `copy-file'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name)) + (tmp-name3 (tramp--test-make-temp-name)) + (tmp-name4 (tramp--test-make-temp-name 'local)) + (tmp-name5 (tramp--test-make-temp-name 'local))) + + ;; Copy on remote side. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (copy-file tmp-name1 tmp-name2) + (should (file-exists-p tmp-name2)) + (with-temp-buffer + (insert-file-contents tmp-name2) + (should (string-equal (buffer-string) "foo"))) + (should-error (copy-file tmp-name1 tmp-name2)) + (copy-file tmp-name1 tmp-name2 'ok) + (make-directory tmp-name3) - (copy-file tmp-name1 tmp-name3) ++ (copy-file tmp-name1 tmp-name3) + (should + (file-exists-p + (expand-file-name (file-name-nondirectory tmp-name1) tmp-name3)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name2)) + (ignore-errors (delete-directory tmp-name3 'recursive))) + + ;; Copy from remote side to local side. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (copy-file tmp-name1 tmp-name4) + (should (file-exists-p tmp-name4)) + (with-temp-buffer + (insert-file-contents tmp-name4) + (should (string-equal (buffer-string) "foo"))) + (should-error (copy-file tmp-name1 tmp-name4)) + (copy-file tmp-name1 tmp-name4 'ok) + (make-directory tmp-name5) - (copy-file tmp-name1 tmp-name5) ++ (copy-file tmp-name1 tmp-name5) + (should + (file-exists-p + (expand-file-name (file-name-nondirectory tmp-name1) tmp-name5)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name4)) + (ignore-errors (delete-directory tmp-name5 'recursive))) + + ;; Copy from local side to remote side. + (unwind-protect + (progn + (write-region "foo" nil tmp-name4 nil 'nomessage) + (copy-file tmp-name4 tmp-name1) + (should (file-exists-p tmp-name1)) + (with-temp-buffer + (insert-file-contents tmp-name1) + (should (string-equal (buffer-string) "foo"))) + (should-error (copy-file tmp-name4 tmp-name1)) + (copy-file tmp-name4 tmp-name1 'ok) + (make-directory tmp-name3) - (copy-file tmp-name4 tmp-name3) ++ (copy-file tmp-name4 tmp-name3) + (should + (file-exists-p + (expand-file-name (file-name-nondirectory tmp-name4) tmp-name3)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name4)) + (ignore-errors (delete-directory tmp-name3 'recursive))))) + + (ert-deftest tramp-test12-rename-file () + "Check `rename-file'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name)) + (tmp-name3 (tramp--test-make-temp-name)) + (tmp-name4 (tramp--test-make-temp-name 'local)) + (tmp-name5 (tramp--test-make-temp-name 'local))) + + ;; Rename on remote side. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (rename-file tmp-name1 tmp-name2) + (should-not (file-exists-p tmp-name1)) + (should (file-exists-p tmp-name2)) + (with-temp-buffer + (insert-file-contents tmp-name2) + (should (string-equal (buffer-string) "foo"))) + (write-region "foo" nil tmp-name1) + (should-error (rename-file tmp-name1 tmp-name2)) + (rename-file tmp-name1 tmp-name2 'ok) + (should-not (file-exists-p tmp-name1)) + (write-region "foo" nil tmp-name1) + (make-directory tmp-name3) - (rename-file tmp-name1 tmp-name3) ++ (rename-file tmp-name1 tmp-name3) + (should-not (file-exists-p tmp-name1)) + (should + (file-exists-p + (expand-file-name (file-name-nondirectory tmp-name1) tmp-name3)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name2)) + (ignore-errors (delete-directory tmp-name3 'recursive))) + + ;; Rename from remote side to local side. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (rename-file tmp-name1 tmp-name4) + (should-not (file-exists-p tmp-name1)) + (should (file-exists-p tmp-name4)) + (with-temp-buffer + (insert-file-contents tmp-name4) + (should (string-equal (buffer-string) "foo"))) + (write-region "foo" nil tmp-name1) + (should-error (rename-file tmp-name1 tmp-name4)) + (rename-file tmp-name1 tmp-name4 'ok) + (should-not (file-exists-p tmp-name1)) + (write-region "foo" nil tmp-name1) + (make-directory tmp-name5) - (rename-file tmp-name1 tmp-name5) ++ (rename-file tmp-name1 tmp-name5) + (should-not (file-exists-p tmp-name1)) + (should + (file-exists-p + (expand-file-name (file-name-nondirectory tmp-name1) tmp-name5)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name4)) + (ignore-errors (delete-directory tmp-name5 'recursive))) + + ;; Rename from local side to remote side. + (unwind-protect + (progn + (write-region "foo" nil tmp-name4 nil 'nomessage) + (rename-file tmp-name4 tmp-name1) + (should-not (file-exists-p tmp-name4)) + (should (file-exists-p tmp-name1)) + (with-temp-buffer + (insert-file-contents tmp-name1) + (should (string-equal (buffer-string) "foo"))) + (write-region "foo" nil tmp-name4 nil 'nomessage) + (should-error (rename-file tmp-name4 tmp-name1)) + (rename-file tmp-name4 tmp-name1 'ok) + (should-not (file-exists-p tmp-name4)) + (write-region "foo" nil tmp-name4 nil 'nomessage) + (make-directory tmp-name3) - (rename-file tmp-name4 tmp-name3) ++ (rename-file tmp-name4 tmp-name3) + (should-not (file-exists-p tmp-name4)) + (should + (file-exists-p + (expand-file-name (file-name-nondirectory tmp-name4) tmp-name3)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name4)) + (ignore-errors (delete-directory tmp-name3 'recursive))))) + + (ert-deftest tramp-test13-make-directory () + "Check `make-directory'. + This tests also `file-directory-p' and `file-accessible-directory-p'." + (skip-unless (tramp--test-enabled)) + + (let* ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (expand-file-name "foo/bar" tmp-name1))) + (unwind-protect + (progn + (make-directory tmp-name1) + (should (file-directory-p tmp-name1)) + (should (file-accessible-directory-p tmp-name1)) + (should-error (make-directory tmp-name2) :type 'file-error) + (make-directory tmp-name2 'parents) + (should (file-directory-p tmp-name2)) + (should (file-accessible-directory-p tmp-name2))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1 'recursive))))) + + (ert-deftest tramp-test14-delete-directory () + "Check `delete-directory'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + ;; Delete empty directory. + (make-directory tmp-name) + (should (file-directory-p tmp-name)) + (delete-directory tmp-name) + (should-not (file-directory-p tmp-name)) + ;; Delete non-empty directory. + (make-directory tmp-name) + (write-region "foo" nil (expand-file-name "bla" tmp-name)) + (should-error (delete-directory tmp-name) :type 'file-error) + (delete-directory tmp-name 'recursive) + (should-not (file-directory-p tmp-name)))) + + (ert-deftest tramp-test15-copy-directory () + "Check `copy-directory'." + (skip-unless (tramp--test-enabled)) + (skip-unless + (not + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-smb-file-name-handler))) + + (let* ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name)) + (tmp-name3 (expand-file-name + (file-name-nondirectory tmp-name1) tmp-name2)) + (tmp-name4 (expand-file-name "foo" tmp-name1)) + (tmp-name5 (expand-file-name "foo" tmp-name2)) + (tmp-name6 (expand-file-name "foo" tmp-name3))) + (unwind-protect + (progn + ;; Copy empty directory. + (make-directory tmp-name1) + (write-region "foo" nil tmp-name4) + (should (file-directory-p tmp-name1)) + (should (file-exists-p tmp-name4)) + (copy-directory tmp-name1 tmp-name2) + (should (file-directory-p tmp-name2)) + (should (file-exists-p tmp-name5)) + ;; Target directory does exist already. + (copy-directory tmp-name1 tmp-name2) + (should (file-directory-p tmp-name3)) + (should (file-exists-p tmp-name6))) + + ;; Cleanup. + (ignore-errors + (delete-directory tmp-name1 'recursive) + (delete-directory tmp-name2 'recursive))))) + + (ert-deftest tramp-test16-directory-files () + "Check `directory-files'." + (skip-unless (tramp--test-enabled)) + + (let* ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (expand-file-name "bla" tmp-name1)) + (tmp-name3 (expand-file-name "foo" tmp-name1))) + (unwind-protect + (progn + (make-directory tmp-name1) + (write-region "foo" nil tmp-name2) + (write-region "bla" nil tmp-name3) + (should (file-directory-p tmp-name1)) + (should (file-exists-p tmp-name2)) + (should (file-exists-p tmp-name3)) + (should (equal (directory-files tmp-name1) '("." ".." "bla" "foo"))) + (should (equal (directory-files tmp-name1 'full) + `(,(concat tmp-name1 "/.") + ,(concat tmp-name1 "/..") + ,tmp-name2 ,tmp-name3))) + (should (equal (directory-files + tmp-name1 nil directory-files-no-dot-files-regexp) + '("bla" "foo"))) + (should (equal (directory-files + tmp-name1 'full directory-files-no-dot-files-regexp) + `(,tmp-name2 ,tmp-name3)))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1 'recursive))))) + + (ert-deftest tramp-test17-insert-directory () + "Check `insert-directory'." + (skip-unless (tramp--test-enabled)) + + (let* ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (expand-file-name "foo" tmp-name1)) + ;; We test for the summary line. Keyword "total" could be localized. + (process-environment + (append '("LANG=C" "LANGUAGE=C" "LC_ALL=C") process-environment))) + (unwind-protect + (progn + (make-directory tmp-name1) + (write-region "foo" nil tmp-name2) + (should (file-directory-p tmp-name1)) + (should (file-exists-p tmp-name2)) + (with-temp-buffer + (insert-directory tmp-name1 nil) + (goto-char (point-min)) + (should (looking-at-p (regexp-quote tmp-name1)))) + (with-temp-buffer + (insert-directory tmp-name1 "-al") + (goto-char (point-min)) + (should (looking-at-p (format "^.+ %s$" (regexp-quote tmp-name1))))) + (with-temp-buffer + (insert-directory (file-name-as-directory tmp-name1) "-al") + (goto-char (point-min)) + (should + (looking-at-p (format "^.+ %s/$" (regexp-quote tmp-name1))))) + (with-temp-buffer + (insert-directory + (file-name-as-directory tmp-name1) "-al" nil 'full-directory-p) + (goto-char (point-min)) + (should + (looking-at-p + (concat + ;; There might be a summary line. + "\\(total.+[[:digit:]]+\n\\)?" + ;; We don't know in which order ".", ".." and "foo" appear. + "\\(.+ \\(\\.?\\.\\|foo\\)\n\\)\\{3\\}"))))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1 'recursive))))) + + (ert-deftest tramp-test18-file-attributes () + "Check `file-attributes'. + This tests also `file-readable-p' and `file-regular-p'." + (skip-unless (tramp--test-enabled)) + + ;; We must use `file-truename' for the temporary directory, because + ;; it could be located on a symlinked directory. This would let the + ;; test fail. + (let* ((tramp-test-temporary-file-directory + (file-truename tramp-test-temporary-file-directory)) + (tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name)) + ;; File name with "//". + (tmp-name3 + (format + "%s%s" + (file-remote-p tmp-name1) + (replace-regexp-in-string + "/" "//" (file-remote-p tmp-name1 'localname)))) + attr) + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + (setq attr (file-attributes tmp-name1)) + (should (consp attr)) + (should (file-exists-p tmp-name1)) + (should (file-readable-p tmp-name1)) + (should (file-regular-p tmp-name1)) + ;; We do not test inodes and device numbers. + (should (null (car attr))) + (should (numberp (nth 1 attr))) ;; Link. + (should (numberp (nth 2 attr))) ;; Uid. + (should (numberp (nth 3 attr))) ;; Gid. + ;; Last access time. + (should (stringp (current-time-string (nth 4 attr)))) + ;; Last modification time. + (should (stringp (current-time-string (nth 5 attr)))) + ;; Last status change time. + (should (stringp (current-time-string (nth 6 attr)))) + (should (numberp (nth 7 attr))) ;; Size. + (should (stringp (nth 8 attr))) ;; Modes. + + (setq attr (file-attributes tmp-name1 'string)) + (should (stringp (nth 2 attr))) ;; Uid. + (should (stringp (nth 3 attr))) ;; Gid. + + (condition-case err + (progn + (make-symbolic-link tmp-name1 tmp-name2) + (should (file-exists-p tmp-name2)) + (should (file-symlink-p tmp-name2)) + (setq attr (file-attributes tmp-name2)) + (should (string-equal + (car attr) + (file-remote-p (file-truename tmp-name1) 'localname))) + (delete-file tmp-name2)) + (file-error + (should (string-equal (error-message-string err) + "make-symbolic-link not supported")))) + + ;; Check, that "//" in symlinks are handled properly. + (with-temp-buffer + (let ((default-directory tramp-test-temporary-file-directory)) + (shell-command + (format + "ln -s %s %s" + (tramp-file-name-localname (tramp-dissect-file-name tmp-name3)) + (tramp-file-name-localname (tramp-dissect-file-name tmp-name2))) + t))) + (when (file-symlink-p tmp-name2) + (setq attr (file-attributes tmp-name2)) + (should + (string-equal + (car attr) + (tramp-file-name-localname (tramp-dissect-file-name tmp-name3)))) + (delete-file tmp-name2)) + + (delete-file tmp-name1) + (make-directory tmp-name1) + (should (file-exists-p tmp-name1)) + (should (file-readable-p tmp-name1)) + (should-not (file-regular-p tmp-name1)) + (setq attr (file-attributes tmp-name1)) + (should (eq (car attr) t))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1)) + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name2))))) + + (ert-deftest tramp-test19-directory-files-and-attributes () + "Check `directory-files-and-attributes'." + (skip-unless (tramp--test-enabled)) + + ;; `directory-files-and-attributes' contains also values for "../". + ;; Ensure that this doesn't change during tests, for + ;; example due to handling temporary files. + (let* ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (expand-file-name "bla" tmp-name1)) + attr) + (unwind-protect + (progn + (make-directory tmp-name1) + (should (file-directory-p tmp-name1)) + (make-directory tmp-name2) + (should (file-directory-p tmp-name2)) + (write-region "foo" nil (expand-file-name "foo" tmp-name2)) + (write-region "bar" nil (expand-file-name "bar" tmp-name2)) + (write-region "boz" nil (expand-file-name "boz" tmp-name2)) + (setq attr (directory-files-and-attributes tmp-name2)) + (should (consp attr)) + ;; Dumb remote shells without perl(1) or stat(1) are not + ;; able to return the date correctly. They say "don't know". + (dolist (elt attr) + (unless + (equal + (nth 5 + (file-attributes (expand-file-name (car elt) tmp-name2))) + '(0 0)) + (should + (equal (file-attributes (expand-file-name (car elt) tmp-name2)) + (cdr elt))))) + (setq attr (directory-files-and-attributes tmp-name2 'full)) + (dolist (elt attr) + (unless (equal (nth 5 (file-attributes (car elt))) '(0 0)) + (should + (equal (file-attributes (car elt)) (cdr elt))))) + (setq attr (directory-files-and-attributes tmp-name2 nil "^b")) + (should (equal (mapcar 'car attr) '("bar" "boz")))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1 'recursive))))) + + (ert-deftest tramp-test20-file-modes () + "Check `file-modes'. + This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." + (skip-unless (tramp--test-enabled)) + (skip-unless + (not + (memq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + '(tramp-adb-file-name-handler + tramp-gvfs-file-name-handler + tramp-smb-file-name-handler)))) + + (let ((tmp-name (tramp--test-make-temp-name))) + (unwind-protect + (progn + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (set-file-modes tmp-name #o777) + (should (= (file-modes tmp-name) #o777)) + (should (file-executable-p tmp-name)) + (should (file-writable-p tmp-name)) + (set-file-modes tmp-name #o444) + (should (= (file-modes tmp-name) #o444)) + (should-not (file-executable-p tmp-name)) + ;; A file is always writable for user "root". + (unless (zerop (nth 2 (file-attributes tmp-name))) + (should-not (file-writable-p tmp-name)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))))) + + (ert-deftest tramp-test21-file-links () + "Check `file-symlink-p'. + This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." + (skip-unless (tramp--test-enabled)) + + ;; We must use `file-truename' for the temporary directory, because + ;; it could be located on a symlinked directory. This would let the + ;; test fail. + (let* ((tramp-test-temporary-file-directory + (file-truename tramp-test-temporary-file-directory)) + (tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name)) + (tmp-name3 (tramp--test-make-temp-name 'local))) + + ;; Check `make-symbolic-link'. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + ;; Method "smb" supports `make-symbolic-link' only if the + ;; remote host has CIFS capabilities. tramp-adb.el and + ;; tramp-gvfs.el do not support symbolic links at all. + (condition-case err + (make-symbolic-link tmp-name1 tmp-name2) + (file-error + (skip-unless + (not (string-equal (error-message-string err) + "make-symbolic-link not supported"))))) + (should (file-symlink-p tmp-name2)) + (should-error (make-symbolic-link tmp-name1 tmp-name2)) + (make-symbolic-link tmp-name1 tmp-name2 'ok-if-already-exists) + (should (file-symlink-p tmp-name2)) + ;; `tmp-name3' is a local file name. + (should-error (make-symbolic-link tmp-name1 tmp-name3))) + + ;; Cleanup. + (ignore-errors + (delete-file tmp-name1) + (delete-file tmp-name2))) + + ;; Check `add-name-to-file'. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + (add-name-to-file tmp-name1 tmp-name2) + (should-not (file-symlink-p tmp-name2)) + (should-error (add-name-to-file tmp-name1 tmp-name2)) + (add-name-to-file tmp-name1 tmp-name2 'ok-if-already-exists) + (should-not (file-symlink-p tmp-name2)) + ;; `tmp-name3' is a local file name. + (should-error (add-name-to-file tmp-name1 tmp-name3))) + + ;; Cleanup. + (ignore-errors + (delete-file tmp-name1) + (delete-file tmp-name2))) + + ;; Check `file-truename'. + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + (make-symbolic-link tmp-name1 tmp-name2) + (should (file-symlink-p tmp-name2)) + (should-not (string-equal tmp-name2 (file-truename tmp-name2))) + (should + (string-equal (file-truename tmp-name1) (file-truename tmp-name2))) + (should (file-equal-p tmp-name1 tmp-name2))) + (ignore-errors + (delete-file tmp-name1) + (delete-file tmp-name2))) + + ;; `file-truename' shall preserve trailing link of directories. + (unless (file-symlink-p tramp-test-temporary-file-directory) + (let* ((dir1 (directory-file-name tramp-test-temporary-file-directory)) + (dir2 (file-name-as-directory dir1))) + (should (string-equal (file-truename dir1) (expand-file-name dir1))) + (should (string-equal (file-truename dir2) (expand-file-name dir2))))))) + + (ert-deftest tramp-test22-file-times () + "Check `set-file-times' and `file-newer-than-file-p'." + (skip-unless (tramp--test-enabled)) + (skip-unless + (not + (memq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + '(tramp-gvfs-file-name-handler tramp-smb-file-name-handler)))) + + (let ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name)) + (tmp-name3 (tramp--test-make-temp-name))) + (unwind-protect + (progn + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + (should (consp (nth 5 (file-attributes tmp-name1)))) + ;; '(0 0) means don't know, and will be replaced by + ;; `current-time'. Therefore, we use '(0 1). + ;; We skip the test, if the remote handler is not able to + ;; set the correct time. + (skip-unless (set-file-times tmp-name1 '(0 1))) + ;; Dumb remote shells without perl(1) or stat(1) are not + ;; able to return the date correctly. They say "don't know". + (unless (equal (nth 5 (file-attributes tmp-name1)) '(0 0)) + (should (equal (nth 5 (file-attributes tmp-name1)) '(0 1))) + (write-region "bla" nil tmp-name2) + (should (file-exists-p tmp-name2)) + (should (file-newer-than-file-p tmp-name2 tmp-name1)) + ;; `tmp-name3' does not exist. + (should (file-newer-than-file-p tmp-name2 tmp-name3)) + (should-not (file-newer-than-file-p tmp-name3 tmp-name1)))) + + ;; Cleanup. + (ignore-errors + (delete-file tmp-name1) + (delete-file tmp-name2))))) + + (ert-deftest tramp-test23-visited-file-modtime () + "Check `set-visited-file-modtime' and `verify-visited-file-modtime'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + (unwind-protect + (progn + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (verify-visited-file-modtime)) + (set-visited-file-modtime '(0 1)) + (should (verify-visited-file-modtime)) + (should (equal (visited-file-modtime) '(0 1 0 0))))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))))) + + (ert-deftest tramp-test24-file-name-completion () + "Check `file-name-completion' and `file-name-all-completions'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + (unwind-protect + (progn + (make-directory tmp-name) + (should (file-directory-p tmp-name)) + (write-region "foo" nil (expand-file-name "foo" tmp-name)) + (write-region "bar" nil (expand-file-name "bold" tmp-name)) + (make-directory (expand-file-name "boz" tmp-name)) + (should (equal (file-name-completion "fo" tmp-name) "foo")) + (should (equal (file-name-completion "b" tmp-name) "bo")) + (should + (equal (file-name-completion "b" tmp-name 'file-directory-p) "boz/")) + (should (equal (file-name-all-completions "fo" tmp-name) '("foo"))) + (should + (equal (sort (file-name-all-completions "b" tmp-name) 'string-lessp) + '("bold" "boz/")))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name 'recursive))))) + + (ert-deftest tramp-test25-load () + "Check `load'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name (tramp--test-make-temp-name))) + (unwind-protect + (progn + (load tmp-name 'noerror 'nomessage) + (should-not (featurep 'tramp-test-load)) + (write-region "(provide 'tramp-test-load)" nil tmp-name) + ;; `load' in lread.c does not pass `must-suffix'. Why? + ;(should-error (load tmp-name nil 'nomessage 'nosuffix 'must-suffix)) + (load tmp-name nil 'nomessage 'nosuffix) + (should (featurep 'tramp-test-load))) + + ;; Cleanup. + (ignore-errors + (and (featurep 'tramp-test-load) (unload-feature 'tramp-test-load)) + (delete-file tmp-name))))) + + (ert-deftest tramp-test26-process-file () + "Check `process-file'." + :tags '(:expensive-test) + (skip-unless (tramp--test-enabled)) + (skip-unless + (not + (memq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + '(tramp-gvfs-file-name-handler tramp-smb-file-name-handler)))) + + (let* ((tmp-name (tramp--test-make-temp-name)) + (fnnd (file-name-nondirectory tmp-name)) + (default-directory tramp-test-temporary-file-directory) + kill-buffer-query-functions) + (unwind-protect + (progn + ;; We cannot use "/bin/true" and "/bin/false"; those paths + ;; do not exist on hydra. + (should (zerop (process-file "true"))) + (should-not (zerop (process-file "false"))) + (should-not (zerop (process-file "binary-does-not-exist"))) + (with-temp-buffer + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (should (zerop (process-file "ls" nil t nil fnnd))) + ;; `ls' could produce colorized output. + (goto-char (point-min)) + (while (re-search-forward tramp-color-escape-sequence-regexp nil t) + (replace-match "" nil nil)) + (should (string-equal (format "%s\n" fnnd) (buffer-string))) + (should-not (get-buffer-window (current-buffer) t)) + + ;; Second run. The output must be appended. + (goto-char (point-max)) + (should (zerop (process-file "ls" nil t t fnnd))) + ;; `ls' could produce colorized output. + (goto-char (point-min)) + (while (re-search-forward tramp-color-escape-sequence-regexp nil t) + (replace-match "" nil nil)) + (should + (string-equal (format "%s\n%s\n" fnnd fnnd) (buffer-string))) + ;; A non-nil DISPLAY must not raise the buffer. + (should-not (get-buffer-window (current-buffer) t)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))))) + + (ert-deftest tramp-test27-start-file-process () + "Check `start-file-process'." + :tags '(:expensive-test) + (skip-unless (tramp--test-enabled)) + (skip-unless + (not + (memq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + '(tramp-adb-file-name-handler + tramp-gvfs-file-name-handler + tramp-smb-file-name-handler)))) + + (let ((default-directory tramp-test-temporary-file-directory) + (tmp-name (tramp--test-make-temp-name)) + kill-buffer-query-functions proc) + (unwind-protect + (with-temp-buffer + (setq proc (start-file-process "test1" (current-buffer) "cat")) + (should (processp proc)) + (should (equal (process-status proc) 'run)) + (process-send-string proc "foo") + (process-send-eof proc) + ;; Read output. + (with-timeout (10 (ert-fail "`start-file-process' timed out")) + (while (< (- (point-max) (point-min)) (length "foo")) + (accept-process-output proc 1))) + (should (string-equal (buffer-string) "foo"))) + + ;; Cleanup. + (ignore-errors (delete-process proc))) + + (unwind-protect + (with-temp-buffer + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (setq proc + (start-file-process + "test2" (current-buffer) + "cat" (file-name-nondirectory tmp-name))) + (should (processp proc)) + ;; Read output. + (with-timeout (10 (ert-fail "`start-file-process' timed out")) + (while (< (- (point-max) (point-min)) (length "foo")) + (accept-process-output proc 1))) + (should (string-equal (buffer-string) "foo"))) + + ;; Cleanup. + (ignore-errors + (delete-process proc) + (delete-file tmp-name))) + + (unwind-protect + (with-temp-buffer + (setq proc (start-file-process "test3" (current-buffer) "cat")) + (should (processp proc)) + (should (equal (process-status proc) 'run)) + (set-process-filter + proc + (lambda (p s) (with-current-buffer (process-buffer p) (insert s)))) + (process-send-string proc "foo") + (process-send-eof proc) + ;; Read output. + (with-timeout (10 (ert-fail "`start-file-process' timed out")) + (while (< (- (point-max) (point-min)) (length "foo")) + (accept-process-output proc 1))) + (should (string-equal (buffer-string) "foo"))) + + ;; Cleanup. + (ignore-errors (delete-process proc))))) + + (ert-deftest tramp-test28-shell-command () + "Check `shell-command'." + :tags '(:expensive-test) + (skip-unless (tramp--test-enabled)) + (skip-unless + (not + (memq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + '(tramp-adb-file-name-handler + tramp-gvfs-file-name-handler + tramp-smb-file-name-handler)))) + + (let ((tmp-name (tramp--test-make-temp-name)) + (default-directory tramp-test-temporary-file-directory) + kill-buffer-query-functions) + (unwind-protect + (with-temp-buffer + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (shell-command + (format "ls %s" (file-name-nondirectory tmp-name)) (current-buffer)) + ;; `ls' could produce colorized output. + (goto-char (point-min)) + (while (re-search-forward tramp-color-escape-sequence-regexp nil t) + (replace-match "" nil nil)) + (should + (string-equal + (format "%s\n" (file-name-nondirectory tmp-name)) (buffer-string)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))) + + (unwind-protect + (with-temp-buffer + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (async-shell-command + (format "ls %s" (file-name-nondirectory tmp-name)) (current-buffer)) + (set-process-sentinel (get-buffer-process (current-buffer)) nil) + ;; Read output. + (with-timeout (10 (ert-fail "`async-shell-command' timed out")) + (while (< (- (point-max) (point-min)) + (1+ (length (file-name-nondirectory tmp-name)))) + (accept-process-output (get-buffer-process (current-buffer)) 1))) + ;; `ls' could produce colorized output. + (goto-char (point-min)) + (while (re-search-forward tramp-color-escape-sequence-regexp nil t) + (replace-match "" nil nil)) + ;; There might be a nasty "Process *Async Shell* finished" message. + (goto-char (point-min)) + (forward-line) + (narrow-to-region (point-min) (point)) + (should + (string-equal + (format "%s\n" (file-name-nondirectory tmp-name)) (buffer-string)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))) + + (unwind-protect + (with-temp-buffer + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (async-shell-command "read line; ls $line" (current-buffer)) + (set-process-sentinel (get-buffer-process (current-buffer)) nil) + (process-send-string + (get-buffer-process (current-buffer)) + (format "%s\n" (file-name-nondirectory tmp-name))) + ;; Read output. + (with-timeout (10 (ert-fail "`async-shell-command' timed out")) + (while (< (- (point-max) (point-min)) + (1+ (length (file-name-nondirectory tmp-name)))) + (accept-process-output (get-buffer-process (current-buffer)) 1))) + ;; `ls' could produce colorized output. + (goto-char (point-min)) + (while (re-search-forward tramp-color-escape-sequence-regexp nil t) + (replace-match "" nil nil)) + ;; There might be a nasty "Process *Async Shell* finished" message. + (goto-char (point-min)) + (forward-line) + (narrow-to-region (point-min) (point)) + (should + (string-equal + (format "%s\n" (file-name-nondirectory tmp-name)) (buffer-string)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))))) + + (defun tramp-test--shell-command-to-string-asynchronously (command) + "Like `shell-command-to-string', but for asynchronous processes." + (with-temp-buffer + (async-shell-command command (current-buffer)) + ;; Suppress nasty messages. + (set-process-sentinel (get-buffer-process (current-buffer)) nil) + (while (get-buffer-process (current-buffer)) + (accept-process-output (get-buffer-process (current-buffer)) 0.1)) + (accept-process-output) + (buffer-substring-no-properties (point-min) (point-max)))) + + ;; This test is inspired by Bug#23952. + (ert-deftest tramp-test29-environment-variables () + "Check that remote processes set / unset environment variables properly." + :tags '(:expensive-test) + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + + (dolist (this-shell-command-to-string + '(;; Synchronously. + shell-command-to-string + ;; Asynchronously. + tramp-test--shell-command-to-string-asynchronously)) + + (let ((default-directory tramp-test-temporary-file-directory) + (shell-file-name "/bin/sh") + (envvar (concat "VAR_" (upcase (md5 (current-time-string))))) + kill-buffer-query-functions) + + (unwind-protect + ;; Set a value. + (let ((process-environment + (cons (concat envvar "=foo") process-environment))) + ;; Default value. + (should + (string-match + "foo" + (funcall + this-shell-command-to-string + (format "echo -n ${%s:?bla}" envvar)))))) + + (unwind-protect + ;; Set the empty value. + (let ((process-environment + (cons (concat envvar "=") process-environment))) + ;; Value is null. + (should + (string-match + "bla" + (funcall + this-shell-command-to-string + (format "echo -n ${%s:?bla}" envvar)))) + ;; Variable is set. + (should + (string-match + (regexp-quote envvar) + (funcall this-shell-command-to-string "set"))))) + + ;; We force a reconnect, in order to have a clean environment. + (tramp-cleanup-connection + (tramp-dissect-file-name tramp-test-temporary-file-directory) + 'keep-debug 'keep-password) + (unwind-protect + ;; Unset the variable. + (let ((tramp-remote-process-environment + (cons (concat envvar "=foo") + tramp-remote-process-environment))) + ;; Set the initial value, we want to unset below. + (should + (string-match + "foo" + (funcall + this-shell-command-to-string + (format "echo -n ${%s:?bla}" envvar)))) + (let ((process-environment + (cons envvar process-environment))) + ;; Variable is unset. + (should + (string-match + "bla" + (funcall + this-shell-command-to-string + (format "echo -n ${%s:?bla}" envvar)))) + ;; Variable is unset. + (should-not + (string-match + (regexp-quote envvar) + (funcall this-shell-command-to-string "set"))))))))) + + (ert-deftest tramp-test30-vc-registered () + "Check `vc-registered'." + :tags '(:expensive-test) + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + + (let* ((default-directory tramp-test-temporary-file-directory) + (tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (expand-file-name "foo" tmp-name1)) + (tramp-remote-process-environment tramp-remote-process-environment) + (vc-handled-backends + (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil + (cond + ((tramp-find-executable v vc-git-program (tramp-get-remote-path v)) + '(Git)) + ((tramp-find-executable v vc-hg-program (tramp-get-remote-path v)) + '(Hg)) + ((tramp-find-executable v vc-bzr-program (tramp-get-remote-path v)) + (setq tramp-remote-process-environment + (cons (format "BZR_HOME=%s" + (file-remote-p tmp-name1 'localname)) + tramp-remote-process-environment)) + ;; We must force a reconnect, in order to activate $BZR_HOME. + (tramp-cleanup-connection + (tramp-dissect-file-name tramp-test-temporary-file-directory) + nil 'keep-password) + '(Bzr)) + (t nil))))) + (skip-unless vc-handled-backends) + (message "%s" vc-handled-backends) + + (unwind-protect + (progn + (make-directory tmp-name1) + (write-region "foo" nil tmp-name2) + (should (file-directory-p tmp-name1)) + (should (file-exists-p tmp-name2)) + (should-not (vc-registered tmp-name1)) + (should-not (vc-registered tmp-name2)) + + (let ((default-directory tmp-name1)) + ;; Create empty repository, and register the file. + ;; Sometimes, creation of repository fails (bzr!); we skip + ;; the test then. + (condition-case nil + (vc-create-repo (car vc-handled-backends)) + (error (skip-unless nil))) + ;; The structure of VC-FILESET is not documented. Let's + ;; hope it won't change. + (condition-case nil + (vc-register + (list (car vc-handled-backends) + (list (file-name-nondirectory tmp-name2)))) + ;; `vc-register' has changed its arguments in Emacs 25.1. + (error + (vc-register + nil (list (car vc-handled-backends) + (list (file-name-nondirectory tmp-name2)))))) + ;; vc-git uses an own process sentinel, Tramp's sentinel + ;; for flushing the cache isn't used. + (dired-uncache (concat (file-remote-p default-directory) "/")) + (should (vc-registered (file-name-nondirectory tmp-name2))))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1 'recursive))))) + + (ert-deftest tramp-test31-make-auto-save-file-name () + "Check `make-auto-save-file-name'." + (skip-unless (tramp--test-enabled)) + + (let ((tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name))) + + (unwind-protect + (progn + ;; Use default `auto-save-file-name-transforms' mechanism. + (let (tramp-auto-save-directory) + (with-temp-buffer + (setq buffer-file-name tmp-name1) + (should + (string-equal + (make-auto-save-file-name) + ;; This is taken from original `make-auto-save-file-name'. + (expand-file-name + (format + "#%s#" + (subst-char-in-string + ?/ ?! (replace-regexp-in-string "!" "!!" tmp-name1))) + temporary-file-directory))))) + + ;; No mapping. + (let (tramp-auto-save-directory auto-save-file-name-transforms) + (with-temp-buffer + (setq buffer-file-name tmp-name1) + (should + (string-equal + (make-auto-save-file-name) + (expand-file-name + (format "#%s#" (file-name-nondirectory tmp-name1)) + tramp-test-temporary-file-directory))))) + + ;; Use default `tramp-auto-save-directory' mechanism. + (let ((tramp-auto-save-directory tmp-name2)) + (with-temp-buffer + (setq buffer-file-name tmp-name1) + (should + (string-equal + (make-auto-save-file-name) + ;; This is taken from Tramp. + (expand-file-name + (format + "#%s#" + (tramp-subst-strs-in-string + '(("_" . "|") + ("/" . "_a") + (":" . "_b") + ("|" . "__") + ("[" . "_l") + ("]" . "_r")) + tmp-name1)) + tmp-name2))) + (should (file-directory-p tmp-name2)))) + + ;; Relative file names shall work, too. + (let ((tramp-auto-save-directory ".")) + (with-temp-buffer + (setq buffer-file-name tmp-name1 + default-directory tmp-name2) + (should + (string-equal + (make-auto-save-file-name) + ;; This is taken from Tramp. + (expand-file-name + (format + "#%s#" + (tramp-subst-strs-in-string + '(("_" . "|") + ("/" . "_a") + (":" . "_b") + ("|" . "__") + ("[" . "_l") + ("]" . "_r")) + tmp-name1)) + tmp-name2))) + (should (file-directory-p tmp-name2))))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-directory tmp-name2 'recursive))))) + + (defun tramp--test-adb-p () + "Check, whether the remote host runs Android. + This requires restrictions of file name syntax." + (tramp-adb-file-name-p tramp-test-temporary-file-directory)) + + (defun tramp--test-ftp-p () + "Check, whether an FTP-like method is used. + This does not support globbing characters in file names (yet)." + ;; Globbing characters are ??, ?* and ?\[. + (and (eq (tramp-find-foreign-file-name-handler + tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler) + (string-match + "ftp$" (file-remote-p tramp-test-temporary-file-directory 'method)))) + + (defun tramp--test-gvfs-p () + "Check, whether the remote host runs a GVFS based method. + This requires restrictions of file name syntax." + (tramp-gvfs-file-name-p tramp-test-temporary-file-directory)) + + (defun tramp--test-smb-or-windows-nt-p () + "Check, whether the locale or remote host runs MS Windows. + This requires restrictions of file name syntax." + (or (eq system-type 'windows-nt) + (tramp-smb-file-name-p tramp-test-temporary-file-directory))) + + (defun tramp--test-hpux-p () + "Check, whether the remote host runs HP-UX. + Several special characters do not work properly there." + ;; We must refill the cache. `file-truename' does it. + (with-parsed-tramp-file-name + (file-truename tramp-test-temporary-file-directory) nil + (string-match "^HP-UX" (tramp-get-connection-property v "uname" "")))) + + (defun tramp--test-check-files (&rest files) + "Run a simple but comprehensive test over every file in FILES." + ;; We must use `file-truename' for the temporary directory, because + ;; it could be located on a symlinked directory. This would let the + ;; test fail. + (let* ((tramp-test-temporary-file-directory + (file-truename tramp-test-temporary-file-directory)) + (tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (tramp--test-make-temp-name 'local)) + (files (delq nil files))) + (unwind-protect + (progn + (make-directory tmp-name1) + (make-directory tmp-name2) + (dolist (elt files) + (let* ((file1 (expand-file-name elt tmp-name1)) + (file2 (expand-file-name elt tmp-name2)) + (file3 (expand-file-name (concat elt "foo") tmp-name1))) + (write-region elt nil file1) + (should (file-exists-p file1)) + + ;; Check file contents. + (with-temp-buffer + (insert-file-contents file1) + (should (string-equal (buffer-string) elt))) + + ;; Copy file both directions. + (copy-file file1 tmp-name2) + (should (file-exists-p file2)) + (delete-file file1) + (should-not (file-exists-p file1)) + (copy-file file2 tmp-name1) + (should (file-exists-p file1)) + + ;; Method "smb" supports `make-symbolic-link' only if the + ;; remote host has CIFS capabilities. tramp-adb.el and + ;; tramp-gvfs.el do not support symbolic links at all. + (condition-case err + (progn + (make-symbolic-link file1 file3) + (should (file-symlink-p file3)) + (should + (string-equal + (expand-file-name file1) (file-truename file3))) + (should + (string-equal + (car (file-attributes file3)) + (file-remote-p (file-truename file1) 'localname))) + ;; Check file contents. + (with-temp-buffer + (insert-file-contents file3) + (should (string-equal (buffer-string) elt))) + (delete-file file3)) + (file-error + (should (string-equal (error-message-string err) + "make-symbolic-link not supported")))))) + + ;; Check file names. + (should (equal (directory-files + tmp-name1 nil directory-files-no-dot-files-regexp) + (sort (copy-sequence files) 'string-lessp))) + (should (equal (directory-files + tmp-name2 nil directory-files-no-dot-files-regexp) + (sort (copy-sequence files) 'string-lessp))) + + ;; `substitute-in-file-name' could return different values. + ;; For `adb', there could be strange file permissions + ;; preventing overwriting a file. We don't care in this + ;; testcase. + (dolist (elt files) + (let ((file1 + (substitute-in-file-name (expand-file-name elt tmp-name1))) + (file2 + (substitute-in-file-name (expand-file-name elt tmp-name2)))) + (ignore-errors (write-region elt nil file1)) + (should (file-exists-p file1)) + (ignore-errors (write-region elt nil file2 nil 'nomessage)) + (should (file-exists-p file2)))) + + (should (equal (directory-files + tmp-name1 nil directory-files-no-dot-files-regexp) + (directory-files + tmp-name2 nil directory-files-no-dot-files-regexp))) + + ;; Check directory creation. We use a subdirectory "foo" + ;; in order to avoid conflicts with previous file name tests. + (dolist (elt files) + (let* ((elt1 (concat elt "foo")) + (file1 (expand-file-name (concat "foo/" elt) tmp-name1)) + (file2 (expand-file-name elt file1)) + (file3 (expand-file-name elt1 file1))) + (make-directory file1 'parents) + (should (file-directory-p file1)) + (write-region elt nil file2) + (should (file-exists-p file2)) + (should + (equal + (directory-files file1 nil directory-files-no-dot-files-regexp) + `(,elt))) + (should + (equal + (caar (directory-files-and-attributes + file1 nil directory-files-no-dot-files-regexp)) + elt)) + + ;; Check symlink in `directory-files-and-attributes'. + (condition-case err + (progn + (make-symbolic-link file2 file3) + (should (file-symlink-p file3)) + (should + (string-equal + (caar (directory-files-and-attributes + file1 nil (regexp-quote elt1))) + elt1)) + (should + (string-equal + (cadr (car (directory-files-and-attributes + file1 nil (regexp-quote elt1)))) + (file-remote-p (file-truename file2) 'localname))) + (delete-file file3) + (should-not (file-exists-p file3))) + (file-error + (should (string-equal (error-message-string err) + "make-symbolic-link not supported")))) + + (delete-file file2) + (should-not (file-exists-p file2)) + (delete-directory file1) + (should-not (file-exists-p file1))))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1 'recursive)) + (ignore-errors (delete-directory tmp-name2 'recursive))))) + + (defun tramp--test-special-characters () + "Perform the test in `tramp-test32-special-characters*'." + ;; Newlines, slashes and backslashes in file names are not + ;; supported. So we don't test. And we don't test the tab + ;; character on Windows or Cygwin, because the backslash is + ;; interpreted as a path separator, preventing "\t" from being + ;; expanded to . + (tramp--test-check-files + (if (or (tramp--test-gvfs-p) (tramp--test-smb-or-windows-nt-p)) + "foo bar baz" + (if (or (tramp--test-adb-p) (eq system-type 'cygwin)) + " foo bar baz " + " foo\tbar baz\t")) + "$foo$bar$$baz$" + "-foo-bar-baz-" + "%foo%bar%baz%" + "&foo&bar&baz&" + (unless (or (tramp--test-ftp-p) + (tramp--test-gvfs-p) + (tramp--test-smb-or-windows-nt-p)) + "?foo?bar?baz?") + (unless (or (tramp--test-ftp-p) + (tramp--test-gvfs-p) + (tramp--test-smb-or-windows-nt-p)) + "*foo*bar*baz*") + (if (or (tramp--test-gvfs-p) (tramp--test-smb-or-windows-nt-p)) + "'foo'bar'baz'" + "'foo\"bar'baz\"") + "#foo~bar#baz~" + (if (or (tramp--test-gvfs-p) (tramp--test-smb-or-windows-nt-p)) + "!foo!bar!baz!" + "!foo|bar!baz|") + (if (or (tramp--test-gvfs-p) (tramp--test-smb-or-windows-nt-p)) + ";foo;bar;baz;" + ":foo;bar:baz;") + (unless (or (tramp--test-gvfs-p) (tramp--test-smb-or-windows-nt-p)) + "bar") + "(foo)bar(baz)" + (unless (or (tramp--test-ftp-p) (tramp--test-gvfs-p)) "[foo]bar[baz]") + "{foo}bar{baz}")) + + ;; These tests are inspired by Bug#17238. + (ert-deftest tramp-test32-special-characters () + "Check special characters in file names." + (skip-unless (tramp--test-enabled)) + + (tramp--test-special-characters)) + + (ert-deftest tramp-test32-special-characters-with-stat () + "Check special characters in file names. + Use the `stat' command." + :tags '(:expensive-test) + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil + (skip-unless (tramp-get-remote-stat v))) + + (let ((tramp-connection-properties + (append + `((,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "perl" nil)) + tramp-connection-properties))) + (tramp--test-special-characters))) + + (ert-deftest tramp-test32-special-characters-with-perl () + "Check special characters in file names. + Use the `perl' command." + :tags '(:expensive-test) + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil + (skip-unless (tramp-get-remote-perl v))) + + (let ((tramp-connection-properties + (append + `((,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "stat" nil) + ;; See `tramp-sh-handle-file-truename'. + (,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "readlink" nil)) + tramp-connection-properties))) + (tramp--test-special-characters))) + + (ert-deftest tramp-test32-special-characters-with-ls () + "Check special characters in file names. + Use the `ls' command." + :tags '(:expensive-test) + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + + (let ((tramp-connection-properties + (append + `((,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "perl" nil) + (,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "stat" nil) + ;; See `tramp-sh-handle-file-truename'. + (,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "readlink" nil)) + tramp-connection-properties))) + (tramp--test-special-characters))) + + (defun tramp--test-utf8 () + "Perform the test in `tramp-test33-utf8*'." + (let* ((utf8 (if (and (eq system-type 'darwin) + (memq 'utf-8-hfs (coding-system-list))) + 'utf-8-hfs 'utf-8)) + (coding-system-for-read utf8) + (coding-system-for-write utf8) + (file-name-coding-system utf8)) + (tramp--test-check-files + (unless (tramp--test-hpux-p) "Γυρίστε το Γαλαξία με Ώτο Στοπ") + (unless (tramp--test-hpux-p) + "أصبح بوسعك الآن تنزيل نسخة كاملة من موسوعة ويكيبيديا العربية لتصفحها بلا اتصال بالإنترنت") + "银河系漫游指南系列" + "Автостопом по гала́ктике"))) + + (ert-deftest tramp-test33-utf8 () + "Check UTF8 encoding in file names and file contents." + (skip-unless (tramp--test-enabled)) + + (tramp--test-utf8)) + + (ert-deftest tramp-test33-utf8-with-stat () + "Check UTF8 encoding in file names and file contents. + Use the `stat' command." + :tags '(:expensive-test) + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil + (skip-unless (tramp-get-remote-stat v))) + + (let ((tramp-connection-properties + (append + `((,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "perl" nil)) + tramp-connection-properties))) + (tramp--test-utf8))) + + (ert-deftest tramp-test33-utf8-with-perl () + "Check UTF8 encoding in file names and file contents. + Use the `perl' command." + :tags '(:expensive-test) + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil + (skip-unless (tramp-get-remote-perl v))) + + (let ((tramp-connection-properties + (append + `((,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "stat" nil) + ;; See `tramp-sh-handle-file-truename'. + (,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "readlink" nil)) + tramp-connection-properties))) + (tramp--test-utf8))) + + (ert-deftest tramp-test33-utf8-with-ls () + "Check UTF8 encoding in file names and file contents. + Use the `ls' command." + :tags '(:expensive-test) + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + + (let ((tramp-connection-properties + (append + `((,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "perl" nil) + (,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "stat" nil) + ;; See `tramp-sh-handle-file-truename'. + (,(regexp-quote (file-remote-p tramp-test-temporary-file-directory)) + "readlink" nil)) + tramp-connection-properties))) + (tramp--test-utf8))) + + ;; This test is inspired by Bug#16928. + (ert-deftest tramp-test34-asynchronous-requests () + "Check parallel asynchronous requests. + Such requests could arrive from timers, process filters and + process sentinels. They shall not disturb each other." + ;; Mark as failed until bug has been fixed. + :expected-result :failed + :tags '(:expensive-test) + (skip-unless (tramp--test-enabled)) + (skip-unless + (eq + (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) + 'tramp-sh-file-name-handler)) + + ;; Keep instrumentation verbosity 0 until Tramp bug is fixed. This + ;; has the side effect, that this test fails instead to abort. Good + ;; for hydra. + (tramp--instrument-test-case 0 + (let* ((tmp-name (tramp--test-make-temp-name)) + (default-directory tmp-name) + (remote-file-name-inhibit-cache t) + timer buffers kill-buffer-query-functions) + + (unwind-protect + (progn + (make-directory tmp-name) + + ;; Setup a timer in order to raise an ordinary command again + ;; and again. `vc-registered' is well suited, because there + ;; are many checks. + (setq + timer + (run-at-time + 0 1 + (lambda () + (when buffers + (vc-registered + (buffer-name (nth (random (length buffers)) buffers))))))) + + ;; Create temporary buffers. The number of buffers + ;; corresponds to the number of processes; it could be + ;; increased in order to make pressure on Tramp. + (dotimes (i 5) + (add-to-list 'buffers (generate-new-buffer "*temp*"))) + + ;; Open asynchronous processes. Set process sentinel. + (dolist (buf buffers) + (async-shell-command "read line; touch $line; echo $line" buf) + (set-process-sentinel + (get-buffer-process buf) + (lambda (proc _state) + (delete-file (buffer-name (process-buffer proc)))))) + + ;; Send a string. Use a random order of the buffers. Mix + ;; with regular operation. + (let ((buffers (copy-sequence buffers)) + buf) + (while buffers + (setq buf (nth (random (length buffers)) buffers)) + (process-send-string + (get-buffer-process buf) (format "'%s'\n" buf)) + (file-attributes (buffer-name buf)) + (setq buffers (delq buf buffers)))) + + ;; Wait until the whole output has been read. + (with-timeout ((* 10 (length buffers)) + (ert-fail "`async-shell-command' timed out")) + (let ((buffers (copy-sequence buffers)) + buf) + (while buffers + (setq buf (nth (random (length buffers)) buffers)) + (if (ignore-errors + (memq (process-status (get-buffer-process buf)) + '(run open))) + (accept-process-output (get-buffer-process buf) 0.1) + (setq buffers (delq buf buffers)))))) + + ;; Check. + (dolist (buf buffers) + (with-current-buffer buf + (should + (string-equal (format "'%s'\n" buf) (buffer-string))))) + (should-not + (directory-files tmp-name nil directory-files-no-dot-files-regexp))) + + ;; Cleanup. + (ignore-errors (cancel-timer timer)) + (ignore-errors (delete-directory tmp-name 'recursive)) + (dolist (buf buffers) + (ignore-errors (kill-buffer buf))))))) + + (ert-deftest tramp-test35-recursive-load () + "Check that Tramp does not fail due to recursive load." + (skip-unless (tramp--test-enabled)) + + (dolist (code + (list + (format + "(expand-file-name %S)" + tramp-test-temporary-file-directory) + (format + "(let ((default-directory %S)) (expand-file-name %S))" + tramp-test-temporary-file-directory + temporary-file-directory))) + (should-not + (string-match + "Recursive load" + (shell-command-to-string + (format + "%s -batch -Q -L %s --eval %s" + (expand-file-name invocation-name invocation-directory) + (mapconcat 'shell-quote-argument load-path " -L ") + (shell-quote-argument code))))))) + + (ert-deftest tramp-test36-unload () + "Check that Tramp and its subpackages unload completely. + Since it unloads Tramp, it shall be the last test to run." + ;; Mark as failed until all symbols are unbound. + :expected-result (if (featurep 'tramp) :failed :passed) + :tags '(:expensive-test) + (when (featurep 'tramp) + (unload-feature 'tramp 'force) + ;; No Tramp feature must be left. + (should-not (featurep 'tramp)) + (should-not (all-completions "tramp" (delq 'tramp-tests features))) + ;; `file-name-handler-alist' must be clean. + (should-not (all-completions "tramp" (mapcar 'cdr file-name-handler-alist))) + ;; There shouldn't be left a bound symbol. We do not regard our + ;; test symbols, and the Tramp unload hooks. + (mapatoms + (lambda (x) + (and (or (boundp x) (functionp x)) + (string-match "^tramp" (symbol-name x)) + (not (string-match "^tramp--?test" (symbol-name x))) + (not (string-match "unload-hook$" (symbol-name x))) + (ert-fail (format "`%s' still bound" x))))) + ;; There shouldn't be left a hook function containing a Tramp + ;; function. We do not regard the Tramp unload hooks. + (mapatoms + (lambda (x) + (and (boundp x) + (string-match "-hooks?$" (symbol-name x)) + (not (string-match "unload-hook$" (symbol-name x))) + (consp (symbol-value x)) + (ignore-errors (all-completions "tramp" (symbol-value x))) + (ert-fail (format "Hook `%s' still contains Tramp function" x))))))) + + ;; TODO: + + ;; * dired-compress-file + ;; * dired-uncache + ;; * file-acl + ;; * file-ownership-preserved-p + ;; * file-selinux-context + ;; * find-backup-file-name + ;; * set-file-acl + ;; * set-file-selinux-context + + ;; * Work on skipped tests. Make a comment, when it is impossible. + ;; * Fix `tramp-test15-copy-directory' for `smb'. Using tar in a pipe + ;; doesn't work well when an interactive password must be provided. + ;; * Fix `tramp-test27-start-file-process' on MS Windows (`process-send-eof'?). + ;; * Fix Bug#16928. Set expected error of `tramp-test34-asynchronous-requests'. + ;; * Fix `tramp-test36-unload' (Not all symbols are unbound). Set + ;; expected error. + + (defun tramp-test-all (&optional interactive) + "Run all tests for \\[tramp]." + (interactive "p") + (funcall + (if interactive 'ert-run-tests-interactively 'ert-run-tests-batch) "^tramp")) + + (provide 'tramp-tests) + ;;; tramp-tests.el ends here diff --cc test/lisp/auth-source-tests.el index 5faa1fe20bf,00000000000..e73f55e2bfa mode 100644,000000..100644 --- a/test/lisp/auth-source-tests.el +++ b/test/lisp/auth-source-tests.el @@@ -1,223 -1,0 +1,223 @@@ +;;; auth-source-tests.el --- Tests for auth-source.el -*- lexical-binding: t; -*- + - ;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2017 Free Software Foundation, Inc. + +;; Author: Damien Cassou , +;; Nicolas Petton + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'auth-source) + +(defvar secrets-enabled t + "Enable the secrets backend to test its features.") + +(defun auth-source-validate-backend (source validation-alist) + (let ((backend (auth-source-backend-parse source))) + (should (auth-source-backend-p backend)) + (dolist (pair validation-alist) + (should (equal (eieio-oref backend (car pair)) (cdr pair)))))) + +(ert-deftest auth-source-backend-parse-macos-keychain () + (auth-source-validate-backend '(:source (:macos-keychain-generic foobar)) + '((:source . "foobar") + (:type . macos-keychain-generic) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-macos-keychain-generic-string () + (auth-source-validate-backend "macos-keychain-generic:foobar" + '((:source . "foobar") + (:type . macos-keychain-generic) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-macos-keychain-internet-string () + (auth-source-validate-backend "macos-keychain-internet:foobar" + '((:source . "foobar") + (:type . macos-keychain-internet) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-macos-keychain-internet-symbol () + (auth-source-validate-backend 'macos-keychain-internet + '((:source . "default") + (:type . macos-keychain-internet) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-macos-keychain-generic-symbol () + (auth-source-validate-backend 'macos-keychain-generic + '((:source . "default") + (:type . macos-keychain-generic) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-macos-keychain-internet-default-string () + (auth-source-validate-backend 'macos-keychain-internet + '((:source . "default") + (:type . macos-keychain-internet) + (:search-function . auth-source-macos-keychain-search) + (:create-function . auth-source-macos-keychain-create)))) + +(ert-deftest auth-source-backend-parse-plstore () + (auth-source-validate-backend '(:source "foo.plist") + '((:source . "foo.plist") + (:type . plstore) + (:search-function . auth-source-plstore-search) + (:create-function . auth-source-plstore-create)))) + +(ert-deftest auth-source-backend-parse-netrc () + (auth-source-validate-backend '(:source "foo") + '((:source . "foo") + (:type . netrc) + (:search-function . auth-source-netrc-search) + (:create-function . auth-source-netrc-create)))) + +(ert-deftest auth-source-backend-parse-netrc-string () + (auth-source-validate-backend "foo" + '((:source . "foo") + (:type . netrc) + (:search-function . auth-source-netrc-search) + (:create-function . auth-source-netrc-create)))) + +(ert-deftest auth-source-backend-parse-secrets () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + (auth-source-validate-backend '(:source (:secrets "foo")) + '((:source . "foo") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create))))) + +(ert-deftest auth-source-backend-parse-secrets-strings () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + (auth-source-validate-backend "secrets:foo" + '((:source . "foo") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create))))) + +(ert-deftest auth-source-backend-parse-secrets-nil-source () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + (auth-source-validate-backend '(:source (:secrets nil)) + '((:source . "session") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create))))) + +(ert-deftest auth-source-backend-parse-secrets-alias () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + ;; Redefine `secrets-get-alias' to map 'foo to "foo" + (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) "foo"))) + (auth-source-validate-backend '(:source (:secrets foo)) + '((:source . "foo") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create)))))) + +(ert-deftest auth-source-backend-parse-secrets-symbol () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + ;; Redefine `secrets-get-alias' to map 'default to "foo" + (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) "foo"))) + (auth-source-validate-backend 'default + '((:source . "foo") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create)))))) + +(ert-deftest auth-source-backend-parse-secrets-no-alias () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + ;; Redefine `secrets-get-alias' to map 'foo to nil (so that + ;; "Login" is used by default + (cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) nil))) + (auth-source-validate-backend '(:source (:secrets foo)) + '((:source . "Login") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create)))))) + +;; TODO This test shows suspicious behavior of auth-source: the +;; "secrets" source is used even though nothing in the input indicates +;; that is what we want +(ert-deftest auth-source-backend-parse-secrets-no-source () + (provide 'secrets) ; simulates the presence of the `secrets' package + (let ((secrets-enabled t)) + (auth-source-validate-backend '(:source '(foo)) + '((:source . "session") + (:type . secrets) + (:search-function . auth-source-secrets-search) + (:create-function . auth-source-secrets-create))))) + +(defun auth-source--test-netrc-parse-entry (entry host user port) + "Parse a netrc entry from buffer." + (auth-source-forget-all-cached) + (setq port (auth-source-ensure-strings port)) + (with-temp-buffer + (insert entry) + (goto-char (point-min)) + (let* ((check (lambda(alist) + (and alist + (auth-source-search-collection + host + (or + (auth-source--aget alist "machine") + (auth-source--aget alist "host") + t)) + (auth-source-search-collection + user + (or + (auth-source--aget alist "login") + (auth-source--aget alist "account") + (auth-source--aget alist "user") + t)) + (auth-source-search-collection + port + (or + (auth-source--aget alist "port") + (auth-source--aget alist "protocol") + t))))) + (entries (auth-source-netrc-parse-entries check 1))) + entries))) + +(ert-deftest auth-source-test-netrc-parse-entry () + (should (equal (auth-source--test-netrc-parse-entry + "machine mymachine1 login user1 password pass1\n" t t t) + '((("password" . "pass1") + ("login" . "user1") + ("machine" . "mymachine1"))))) + (should (equal (auth-source--test-netrc-parse-entry + "machine mymachine1 login user1 password pass1 port 100\n" + t t t) + '((("port" . "100") + ("password" . "pass1") + ("login" . "user1") + ("machine" . "mymachine1")))))) + +(provide 'auth-source-tests) +;;; auth-source-tests.el ends here diff --cc test/lisp/autorevert-tests.el index 2f951c0c9aa,00000000000..aea855ae02f mode 100644,000000..100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el @@@ -1,326 -1,0 +1,326 @@@ +;;; auto-revert-tests.el --- Tests of auto-revert + - ;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2017 Free Software Foundation, Inc. + +;; Author: Michael Albinus + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; A whole test run can be performed calling the command `auto-revert-test-all'. + +;;; Code: + +(require 'ert) +(require 'autorevert) +(setq auto-revert-notify-exclude-dir-regexp "nothing-to-be-excluded" + auto-revert-stop-on-user-input nil) + +(defconst auto-revert--timeout 10 + "Time to wait until a message appears in the *Messages* buffer.") + +(defun auto-revert--wait-for-revert (buffer) + "Wait until the *Messages* buffer reports reversion of BUFFER." + (with-timeout (auto-revert--timeout nil) + (with-current-buffer "*Messages*" + (while + (null (string-match + (format-message "Reverting buffer `%s'." (buffer-name buffer)) + (buffer-string))) + (if (with-current-buffer buffer auto-revert-use-notify) + (read-event nil nil 0.1) + (sleep-for 0.1)))))) + +(ert-deftest auto-revert-test00-auto-revert-mode () + "Check autorevert for a file." + ;; `auto-revert-buffers' runs every 5". And we must wait, until the + ;; file has been reverted. + (let ((tmpfile (make-temp-file "auto-revert-test")) + buf) + (unwind-protect + (progn + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (write-region "any text" nil tmpfile nil 'no-message) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (sleep-for 1) + (auto-revert-mode 1) + (should auto-revert-mode) + + ;; Modify file. We wait for a second, in order to have + ;; another timestamp. + (sleep-for 1) + (write-region "another text" nil tmpfile nil 'no-message) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf) + (should (string-match "another text" (buffer-string))) + + ;; When the buffer is modified, it shall not be reverted. + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (set-buffer-modified-p t) + (sleep-for 1) + (write-region "any text" nil tmpfile nil 'no-message) + + ;; Check, that the buffer hasn't been reverted. + (auto-revert--wait-for-revert buf) + (should-not (string-match "any text" (buffer-string))))) + + ;; Exit. + (with-current-buffer "*Messages*" (widen)) + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf)) + (ignore-errors (delete-file tmpfile))))) + +;; This is inspired by Bug#21841. +(ert-deftest auto-revert-test01-auto-revert-several-files () + "Check autorevert for several files at once." + :tags '(:expensive-test) + (skip-unless (executable-find "cp")) + + (let* ((cp (executable-find "cp")) + (tmpdir1 (make-temp-file "auto-revert-test" 'dir)) + (tmpdir2 (make-temp-file "auto-revert-test" 'dir)) + (tmpfile1 + (make-temp-file (expand-file-name "auto-revert-test" tmpdir1))) + (tmpfile2 + (make-temp-file (expand-file-name "auto-revert-test" tmpdir1))) + buf1 buf2) + (unwind-protect + (progn + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (write-region "any text" nil tmpfile1 nil 'no-message) + (setq buf1 (find-file-noselect tmpfile1)) + (write-region "any text" nil tmpfile2 nil 'no-message) + (setq buf2 (find-file-noselect tmpfile2)) + + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that + ;; it returns nil. + (sleep-for 1) + (auto-revert-mode 1) + (should auto-revert-mode))) + + ;; Modify files. We wait for a second, in order to have + ;; another timestamp. + (sleep-for 1) + (write-region + "another text" nil + (expand-file-name (file-name-nondirectory tmpfile1) tmpdir2) + nil 'no-message) + (write-region + "another text" nil + (expand-file-name (file-name-nondirectory tmpfile2) tmpdir2) + nil 'no-message) + ;;(copy-directory tmpdir2 tmpdir1 nil 'copy-contents) + ;; Strange, that `copy-directory' does not work as expected. + ;; The following shell command is not portable on all + ;; platforms, unfortunately. + (shell-command (format "%s -f %s/* %s" cp tmpdir2 tmpdir1)) + + ;; Check, that the buffers have been reverted. + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf + (auto-revert--wait-for-revert buf) + (should (string-match "another text" (buffer-string)))))) + + ;; Exit. + (with-current-buffer "*Messages*" (widen)) + (ignore-errors + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))) + (ignore-errors (delete-directory tmpdir1 'recursive)) + (ignore-errors (delete-directory tmpdir2 'recursive))))) + +;; This is inspired by Bug#23276. +(ert-deftest auto-revert-test02-auto-revert-deleted-file () + "Check autorevert for a deleted file." + :tags '(:expensive-test) + + (let ((tmpfile (make-temp-file "auto-revert-test")) + buf) + (unwind-protect + (progn + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (write-region "any text" nil tmpfile nil 'no-message) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that + ;; it returns nil. + (sleep-for 1) + (auto-revert-mode 1) + (should auto-revert-mode) + + ;; Remove file while reverting. We simulate this by + ;; modifying `before-revert-hook'. + (add-hook + 'before-revert-hook + (lambda () (delete-file buffer-file-name)) + nil t) + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (sleep-for 1) + (write-region "another text" nil tmpfile nil 'no-message) + + ;; Check, that the buffer hasn't been reverted. File + ;; notification should be disabled, falling back to + ;; polling. + (auto-revert--wait-for-revert buf) + (should (string-match "any text" (buffer-string))) + (should-not auto-revert-use-notify) + + ;; Once the file has been recreated, the buffer shall be + ;; reverted. + (kill-local-variable 'before-revert-hook) + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (sleep-for 1) + (write-region "another text" nil tmpfile nil 'no-message) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf) + (should (string-match "another text" (buffer-string))) + + ;; An empty file shall still be reverted. + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (sleep-for 1) + (write-region "" nil tmpfile nil 'no-message) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf) + (should (string-equal "" (buffer-string))))) + + ;; Exit. + (with-current-buffer "*Messages*" (widen)) + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf)) + (ignore-errors (delete-file tmpfile))))) + +(ert-deftest auto-revert-test03-auto-revert-tail-mode () + "Check autorevert tail mode." + ;; `auto-revert-buffers' runs every 5". And we must wait, until the + ;; file has been reverted. + (let ((tmpfile (make-temp-file "auto-revert-test")) + buf) + (unwind-protect + (progn + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (write-region "any text" nil tmpfile nil 'no-message) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (sleep-for 1) + (auto-revert-tail-mode 1) + (should auto-revert-tail-mode) + (erase-buffer) + (insert "modified text\n") + (set-buffer-modified-p nil) + + ;; Modify file. We wait for a second, in order to have + ;; another timestamp. + (sleep-for 1) + (write-region "another text" nil tmpfile 'append 'no-message) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf) + (should + (string-match "modified text\nanother text" (buffer-string))))) + + ;; Exit. + (with-current-buffer "*Messages*" (widen)) + (ignore-errors (kill-buffer buf)) + (ignore-errors (delete-file tmpfile))))) + +(ert-deftest auto-revert-test04-auto-revert-mode-dired () + "Check autorevert for dired." + ;; `auto-revert-buffers' runs every 5". And we must wait, until the + ;; file has been reverted. + (let* ((tmpfile (make-temp-file "auto-revert-test")) + (name (file-name-nondirectory tmpfile)) + buf) + (unwind-protect + (progn + (setq buf (dired-noselect temporary-file-directory)) + (with-current-buffer buf + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (sleep-for 1) + (auto-revert-mode 1) + (should auto-revert-mode) + (should + (string-match name (substring-no-properties (buffer-string)))) + + ;; Delete file. We wait for a second, in order to have + ;; another timestamp. + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (sleep-for 1) + (delete-file tmpfile) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf) + (should-not + (string-match name (substring-no-properties (buffer-string)))) + + ;; Make dired buffer modified. Check, that the buffer has + ;; been still reverted. + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (set-buffer-modified-p t) + (sleep-for 1) + (write-region "any text" nil tmpfile nil 'no-message) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf) + (should + (string-match name (substring-no-properties (buffer-string)))))) + + ;; Exit. + (with-current-buffer "*Messages*" (widen)) + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf)) + (ignore-errors (delete-file tmpfile))))) + +(defun auto-revert-test-all (&optional interactive) + "Run all tests for \\[auto-revert]." + (interactive "p") + (if interactive + (ert-run-tests-interactively "^auto-revert-") + (ert-run-tests-batch "^auto-revert-"))) + +(provide 'auto-revert-tests) +;;; auto-revert-tests.el ends here diff --cc test/lisp/calc/calc-tests.el index c1fb1695c78,00000000000..8f56d48d01d mode 100644,000000..100644 --- a/test/lisp/calc/calc-tests.el +++ b/test/lisp/calc/calc-tests.el @@@ -1,94 -1,0 +1,94 @@@ +;;; calc-tests.el --- tests for calc -*- lexical-binding: t; -*- + - ;; Copyright (C) 2014-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2014-2017 Free Software Foundation, Inc. + +;; Author: Leo Liu +;; Keywords: maint + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'cl-lib) +(require 'ert) +(require 'calc) +(require 'calc-ext) +(require 'calc-units) + +;; XXX The order in which calc libraries (in particular calc-units) +;; are loaded influences whether a calc integer in an expression +;; involving units is represented as a lisp integer or a calc float, +;; see bug#19582. Until this will be fixed the following function can +;; be used to compare such calc expressions. +(defun calc-tests-equal (a b) + "Like `equal' but allow for different representations of numbers. +For example: (calc-tests-equal 10 '(float 1 1)) => t. +A and B should be calc expressions." + (cond ((math-numberp a) + (and (math-numberp b) + (math-equal a b))) + ((atom a) + (equal a b)) + ((consp b) + ;; Can't be dotted or circular. + (and (= (length a) (length b)) + (equal (car a) (car b)) + (cl-every #'calc-tests-equal (cdr a) (cdr b)))))) + +(defun calc-tests-simple (fun string &rest args) + "Push STRING on the calc stack, then call FUN and return the new top. +The result is a calc (i.e., lisp) expression, not its string representation. +Also pop the entire stack afterwards. +An existing calc stack is reused, otherwise a new one is created." + (calc-eval string 'push) + (prog1 + (ignore-errors + (apply fun args) + (calc-top-n 1)) + (calc-pop 0))) + +(ert-deftest test-math-bignum () + ;; bug#17556 + (let ((n (math-bignum most-negative-fixnum))) + (should (math-negp n)) + (should (cl-notany #'cl-minusp (cdr n))))) + +(ert-deftest test-calc-remove-units () + (should (calc-tests-equal (calc-tests-simple #'calc-remove-units "-1 m") -1))) + +(ert-deftest test-calc-extract-units () + (should (calc-tests-equal (calc-tests-simple #'calc-extract-units "-1 m") + '(var m var-m))) + (should (calc-tests-equal (calc-tests-simple #'calc-extract-units "-1 m*cm") + '(* (float 1 -2) (^ (var m var-m) 2))))) + +(ert-deftest test-calc-convert-units () + ;; Used to ask for `(The expression is unitless when simplified) Old Units: '. + (should (calc-tests-equal (calc-tests-simple #'calc-convert-units "-1 m" nil "cm") + '(* -100 (var cm var-cm)))) + ;; Gave wrong result. + (should (calc-tests-equal (calc-tests-simple #'calc-convert-units "-1 m" + (math-read-expr "1m") "cm") + '(* -100 (var cm var-cm))))) + +(provide 'calc-tests) +;;; calc-tests.el ends here + +;; Local Variables: +;; bug-reference-url-format: "http://debbugs.gnu.org/%s" +;; End: diff --cc test/lisp/calendar/icalendar-tests.el index 307d687f2af,00000000000..3e090029808 mode 100644,000000..100644 --- a/test/lisp/calendar/icalendar-tests.el +++ b/test/lisp/calendar/icalendar-tests.el @@@ -1,2330 -1,0 +1,2330 @@@ +;; icalendar-tests.el --- Test suite for icalendar.el + - ;; Copyright (C) 2005, 2008-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2005, 2008-2017 Free Software Foundation, Inc. + +;; Author: Ulf Jasper +;; Created: March 2005 +;; Keywords: calendar +;; Human-Keywords: calendar, diary, iCalendar, vCalendar + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; TODO: +;; - Add more unit tests for functions, timezone etc. + +;; Note: Watch the trailing blank that is added on import. + +;;; Code: + +(require 'ert) +(require 'icalendar) + +;; ====================================================================== +;; Helpers +;; ====================================================================== + +(defun icalendar-tests--get-ical-event (ical-string) + "Return iCalendar event for ICAL-STRING." + (save-excursion + (with-temp-buffer + (insert ical-string) + (goto-char (point-min)) + (car (icalendar--read-element nil nil))))) + +(defun icalendar-tests--trim (string) + "Remove leading and trailing whitespace from STRING." + (replace-regexp-in-string "[ \t\n]+\\'" "" + (replace-regexp-in-string "\\`[ \t\n]+" "" string))) + +;; ====================================================================== +;; Tests of functions +;; ====================================================================== + +(ert-deftest icalendar--create-uid () + "Test for `icalendar--create-uid'." + (let* ((icalendar-uid-format "xxx-%t-%c-%h-%u-%s") + (icalendar--uid-count 77) + (entry-full "30.06.1964 07:01 blahblah") + (hash (format "%d" (abs (sxhash entry-full)))) + (contents "DTSTART:19640630T070100\nblahblah") + (username (or user-login-name "UNKNOWN_USER"))) + (cl-letf (((symbol-function 'current-time) (lambda () '(1 2 3)))) + (should (= 77 icalendar--uid-count)) + (should (string= (concat "xxx-123-77-" hash "-" username "-19640630") + (icalendar--create-uid entry-full contents))) + (should (= 78 icalendar--uid-count))) + (setq contents "blahblah") + (setq icalendar-uid-format "yyy%syyy") + (should (string= (concat "yyyDTSTARTyyy") + (icalendar--create-uid entry-full contents))))) + +(ert-deftest icalendar-convert-anniversary-to-ical () + "Test method for `icalendar--convert-anniversary-to-ical'." + (let* ((calendar-date-style 'iso) + result) + (setq result (icalendar--convert-anniversary-to-ical + "" "%%(diary-anniversary 1964 6 30) g")) + (should (consp result)) + (should (string= (concat + "\nDTSTART;VALUE=DATE:19640630" + "\nDTEND;VALUE=DATE:19640701" + "\nRRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=06;BYMONTHDAY=30") + (car result))) + (should (string= "g" (cdr result))))) + +(ert-deftest icalendar--convert-cyclic-to-ical () + "Test method for `icalendar--convert-cyclic-to-ical'." + (let* ((calendar-date-style 'iso) + result) + (setq result (icalendar--convert-block-to-ical + "" "%%(diary-block 2004 7 19 2004 8 27) Sommerferien")) + (should (consp result)) + (should (string= (concat + "\nDTSTART;VALUE=DATE:20040719" + "\nDTEND;VALUE=DATE:20040828") + (car result))) + (should (string= "Sommerferien" (cdr result))))) + +(ert-deftest icalendar--convert-block-to-ical () + "Test method for `icalendar--convert-block-to-ical'." + (let* ((calendar-date-style 'iso) + result) + (setq result (icalendar--convert-block-to-ical + "" "%%(diary-block 2004 7 19 2004 8 27) Sommerferien")) + (should (consp result)) + (should (string= (concat + "\nDTSTART;VALUE=DATE:20040719" + "\nDTEND;VALUE=DATE:20040828") + (car result))) + (should (string= "Sommerferien" (cdr result))))) + +(ert-deftest icalendar--convert-yearly-to-ical () + "Test method for `icalendar--convert-yearly-to-ical'." + (let* ((calendar-date-style 'iso) + result + (calendar-month-name-array + ["January" "February" "March" "April" "May" "June" "July" "August" + "September" "October" "November" "December"])) + (setq result (icalendar--convert-yearly-to-ical "" "May 1 Tag der Arbeit")) + (should (consp result)) + (should (string= (concat + "\nDTSTART;VALUE=DATE:19000501" + "\nDTEND;VALUE=DATE:19000502" + "\nRRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=5;BYMONTHDAY=1") + (car result))) + (should (string= "Tag der Arbeit" (cdr result))))) + +(ert-deftest icalendar--convert-weekly-to-ical () + "Test method for `icalendar--convert-weekly-to-ical'." + (let* ((calendar-date-style 'iso) + result + (calendar-day-name-array + ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" + "Saturday"])) + (setq result (icalendar--convert-weekly-to-ical "" "Monday 8:30 subject")) + (should (consp result)) + (should (string= (concat "\nDTSTART;VALUE=DATE-TIME:20050103T083000" + "\nDTEND;VALUE=DATE-TIME:20050103T093000" + "\nRRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO") + (car result))) + (should (string= "subject" (cdr result))))) + +(ert-deftest icalendar--convert-sexp-to-ical () + "Test method for `icalendar--convert-sexp-to-ical'." + (let* (result + (icalendar-export-sexp-enumeration-days 3)) + ;; test case %%(diary-hebrew-date) + (setq result (icalendar--convert-sexp-to-ical "" "%%(diary-hebrew-date)")) + (should (consp result)) + (should (eq icalendar-export-sexp-enumeration-days (length result))) + (mapc (lambda (i) + (should (consp i)) + (should (string-match "Hebrew date (until sunset): .*" (cdr i)))) + result))) + +(ert-deftest icalendar--convert-to-ical () + "Test method for `icalendar--convert-to-ical'." + (let* (result + (icalendar-export-sexp-enumerate-all t) + (icalendar-export-sexp-enumeration-days 3) + (calendar-date-style 'iso)) + ;; test case: %%(diary-anniversary 1642 12 25) Newton + ;; forced enumeration not matching the actual day --> empty + (setq result (icalendar--convert-sexp-to-ical + "" "%%(diary-anniversary 1642 12 25) Newton's birthday" + (encode-time 1 1 1 6 12 2014))) + (should (null result)) + ;; test case: %%(diary-anniversary 1642 12 25) Newton + ;; enumeration does match the actual day --> + (setq result (icalendar--convert-sexp-to-ical + "" "%%(diary-anniversary 1642 12 25) Newton's birthday" + (encode-time 1 1 1 24 12 2014))) + (should (= 1 (length result))) + (should (consp (car result))) + (should (string-match + "\nDTSTART;VALUE=DATE:20141225\nDTEND;VALUE=DATE:20141226" + (car (car result)))) + (should (string-match "Newton's birthday" (cdr (car result)))))) + +(ert-deftest icalendar--parse-vtimezone () + "Test method for `icalendar--parse-vtimezone'." + (let (vtimezone result) + (setq vtimezone (icalendar-tests--get-ical-event "BEGIN:VTIMEZONE +TZID:thename +BEGIN:STANDARD +DTSTART:16010101T040000 +TZOFFSETFROM:+0300 +TZOFFSETTO:+0200 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=-1SU;BYMONTH=10 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T030000 +TZOFFSETFROM:+0200 +TZOFFSETTO:+0300 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=-1SU;BYMONTH=3 +END:DAYLIGHT +END:VTIMEZONE +")) + (setq result (icalendar--parse-vtimezone vtimezone)) + (should (string= "thename" (car result))) + (message (cdr result)) + (should (string= "STD-02:00DST-03:00,M3.5.0/03:00:00,M10.5.0/04:00:00" + (cdr result))) + (setq vtimezone (icalendar-tests--get-ical-event "BEGIN:VTIMEZONE +TZID:anothername, with a comma +BEGIN:STANDARD +DTSTART:16010101T040000 +TZOFFSETFROM:+0300 +TZOFFSETTO:+0200 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=2MO;BYMONTH=10 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T030000 +TZOFFSETFROM:+0200 +TZOFFSETTO:+0300 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=2MO;BYMONTH=3 +END:DAYLIGHT +END:VTIMEZONE +")) + (setq result (icalendar--parse-vtimezone vtimezone)) + (should (string= "anothername, with a comma" (car result))) + (message (cdr result)) + (should (string= "STD-02:00DST-03:00,M3.2.1/03:00:00,M10.2.1/04:00:00" + (cdr result))) + ;; offsetfrom = offsetto + (setq vtimezone (icalendar-tests--get-ical-event "BEGIN:VTIMEZONE +TZID:Kolkata, Chennai, Mumbai, New Delhi +X-MICROSOFT-CDO-TZID:23 +BEGIN:STANDARD +DTSTART:16010101T000000 +TZOFFSETFROM:+0530 +TZOFFSETTO:+0530 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T000000 +TZOFFSETFROM:+0530 +TZOFFSETTO:+0530 +END:DAYLIGHT +END:VTIMEZONE +")) + (setq result (icalendar--parse-vtimezone vtimezone)) + (should (string= "Kolkata, Chennai, Mumbai, New Delhi" (car result))) + (message (cdr result)) + (should (string= "STD-05:30DST-05:30,M1.1.1/00:00:00,M1.1.1/00:00:00" + (cdr result))))) + +(ert-deftest icalendar--convert-ordinary-to-ical () + "Test method for `icalendar--convert-ordinary-to-ical'." + (let* ((calendar-date-style 'iso) + result) + ;; without time + (setq result (icalendar--convert-ordinary-to-ical "&?" "2010 2 15 subject")) + (should (consp result)) + (should (string= "\nDTSTART;VALUE=DATE:20100215\nDTEND;VALUE=DATE:20100216" + (car result))) + (should (string= "subject" (cdr result))) + + ;; with start time + (setq result (icalendar--convert-ordinary-to-ical + "&?" "&2010 2 15 12:34 s")) + (should (consp result)) + (should (string= (concat "\nDTSTART;VALUE=DATE-TIME:20100215T123400" + "\nDTEND;VALUE=DATE-TIME:20100215T133400") + (car result))) + (should (string= "s" (cdr result))) + + ;; with time + (setq result (icalendar--convert-ordinary-to-ical + "&?" "&2010 2 15 12:34-23:45 s")) + (should (consp result)) + (should (string= (concat "\nDTSTART;VALUE=DATE-TIME:20100215T123400" + "\nDTEND;VALUE=DATE-TIME:20100215T234500") + (car result))) + (should (string= "s" (cdr result))) + + ;; with time, again -- test bug#5549 + (setq result (icalendar--convert-ordinary-to-ical + "x?" "x2010 2 15 0:34-1:45 s")) + (should (consp result)) + (should (string= (concat "\nDTSTART;VALUE=DATE-TIME:20100215T003400" + "\nDTEND;VALUE=DATE-TIME:20100215T014500") + (car result))) + (should (string= "s" (cdr result))))) + +(ert-deftest icalendar--diarytime-to-isotime () + "Test method for `icalendar--diarytime-to-isotime'." + (should (string= "T011500" + (icalendar--diarytime-to-isotime "01:15" ""))) + (should (string= "T011500" + (icalendar--diarytime-to-isotime "1:15" ""))) + (should (string= "T000100" + (icalendar--diarytime-to-isotime "0:01" ""))) + (should (string= "T010000" + (icalendar--diarytime-to-isotime "0100" ""))) + (should (string= "T010000" + (icalendar--diarytime-to-isotime "0100" "am"))) + (should (string= "T130000" + (icalendar--diarytime-to-isotime "0100" "pm"))) + (should (string= "T120000" + (icalendar--diarytime-to-isotime "1200" ""))) + (should (string= "T171700" + (icalendar--diarytime-to-isotime "17:17" ""))) + (should (string= "T000000" + (icalendar--diarytime-to-isotime "1200" "am"))) + (should (string= "T000100" + (icalendar--diarytime-to-isotime "1201" "am"))) + (should (string= "T005900" + (icalendar--diarytime-to-isotime "1259" "am"))) + (should (string= "T120000" + (icalendar--diarytime-to-isotime "1200" "pm"))) + (should (string= "T120100" + (icalendar--diarytime-to-isotime "1201" "pm"))) + (should (string= "T125900" + (icalendar--diarytime-to-isotime "1259" "pm"))) + (should (string= "T150000" + (icalendar--diarytime-to-isotime "3" "pm")))) + +(ert-deftest icalendar--datetime-to-diary-date () + "Test method for `icalendar--datetime-to-diary-date'." + (let* ((datetime '(59 59 23 31 12 2008)) + (calendar-date-style 'iso)) + (should (string= "2008 12 31" + (icalendar--datetime-to-diary-date datetime))) + (setq calendar-date-style 'european) + (should (string= "31 12 2008" + (icalendar--datetime-to-diary-date datetime))) + (setq calendar-date-style 'american) + (should (string= "12 31 2008" + (icalendar--datetime-to-diary-date datetime))))) + +(ert-deftest icalendar--datestring-to-isodate () + "Test method for `icalendar--datestring-to-isodate'." + (let ((calendar-date-style 'iso)) + ;; numeric iso + (should (string= "20080511" + (icalendar--datestring-to-isodate "2008 05 11"))) + (should (string= "20080531" + (icalendar--datestring-to-isodate "2008 05 31"))) + (should (string= "20080602" + (icalendar--datestring-to-isodate "2008 05 31" 2))) + + ;; numeric european + (setq calendar-date-style 'european) + (should (string= "20080511" + (icalendar--datestring-to-isodate "11 05 2008"))) + (should (string= "20080531" + (icalendar--datestring-to-isodate "31 05 2008"))) + (should (string= "20080602" + (icalendar--datestring-to-isodate "31 05 2008" 2))) + + ;; numeric american + (setq calendar-date-style 'american) + (should (string= "20081105" + (icalendar--datestring-to-isodate "11 05 2008"))) + (should (string= "20081230" + (icalendar--datestring-to-isodate "12 30 2008"))) + (should (string= "20090101" + (icalendar--datestring-to-isodate "12 30 2008" 2))) + + ;; non-numeric + (setq calendar-date-style nil) ;not necessary for conversion + (should (string= "20081105" + (icalendar--datestring-to-isodate "Nov 05 2008"))) + (should (string= "20081105" + (icalendar--datestring-to-isodate "05 Nov 2008"))) + (should (string= "20081105" + (icalendar--datestring-to-isodate "2008 Nov 05"))))) + +(ert-deftest icalendar--first-weekday-of-year () + "Test method for `icalendar-first-weekday-of-year'." + (should (eq 1 (icalendar-first-weekday-of-year "TU" 2008))) + (should (eq 3 (icalendar-first-weekday-of-year "WE" 2007))) + (should (eq 5 (icalendar-first-weekday-of-year "TH" 2006))) + (should (eq 7 (icalendar-first-weekday-of-year "FR" 2005))) + (should (eq 3 (icalendar-first-weekday-of-year "SA" 2004))) + (should (eq 5 (icalendar-first-weekday-of-year "SU" 2003))) + (should (eq 7 (icalendar-first-weekday-of-year "MO" 2002))) + (should (eq 3 (icalendar-first-weekday-of-year "MO" 2000))) + (should (eq 1 (icalendar-first-weekday-of-year "TH" 1970)))) + +(ert-deftest icalendar--import-format-sample () + "Test method for `icalendar-import-format-sample'." + (should (string= (concat "SUMMARY='a' DESCRIPTION='b' LOCATION='c' " + "ORGANIZER='d' STATUS='' URL='' CLASS=''") + (icalendar-import-format-sample + (icalendar-tests--get-ical-event "BEGIN:VEVENT +DTSTAMP:20030509T043439Z +DTSTART:20030509T103000 +SUMMARY:a +ORGANIZER:d +LOCATION:c +DTEND:20030509T153000 +DESCRIPTION:b +END:VEVENT +"))))) + +(ert-deftest icalendar--format-ical-event () + "Test `icalendar--format-ical-event'." + (let ((icalendar-import-format "%s%d%l%o%t%u%c") + (icalendar-import-format-summary "SUM %s") + (icalendar-import-format-location " LOC %s") + (icalendar-import-format-description " DES %s") + (icalendar-import-format-organizer " ORG %s") + (icalendar-import-format-status " STA %s") + (icalendar-import-format-url " URL %s") + (icalendar-import-format-class " CLA %s") + (event (icalendar-tests--get-ical-event "BEGIN:VEVENT +DTSTAMP:20030509T043439Z +DTSTART:20030509T103000 +SUMMARY:sum +ORGANIZER:org +LOCATION:loc +DTEND:20030509T153000 +DESCRIPTION:des +END:VEVENT +"))) + (should (string= "SUM sum DES des LOC loc ORG org" + (icalendar--format-ical-event event))) + (setq icalendar-import-format (lambda (&rest ignore) + "helloworld")) + (should (string= "helloworld" (icalendar--format-ical-event event))) + (setq icalendar-import-format + (lambda (e) + (format "-%s-%s-%s-%s-%s-%s-%s-" + (icalendar--get-event-property event 'SUMMARY) + (icalendar--get-event-property event 'DESCRIPTION) + (icalendar--get-event-property event 'LOCATION) + (icalendar--get-event-property event 'ORGANIZER) + (icalendar--get-event-property event 'STATUS) + (icalendar--get-event-property event 'URL) + (icalendar--get-event-property event 'CLASS)))) + (should (string= "-sum-des-loc-org-nil-nil-nil-" + (icalendar--format-ical-event event))))) + +(ert-deftest icalendar--parse-summary-and-rest () + "Test `icalendar--parse-summary-and-rest'." + (let ((icalendar-import-format "%s%d%l%o%t%u%c") + (icalendar-import-format-summary "SUM %s") + (icalendar-import-format-location " LOC %s") + (icalendar-import-format-description " DES %s") + (icalendar-import-format-organizer " ORG %s") + (icalendar-import-format-status " STA %s") + (icalendar-import-format-url " URL %s") + (icalendar-import-format-class " CLA %s") + (result)) + (setq result (icalendar--parse-summary-and-rest "SUM sum ORG org")) + (should (string= "org" (cdr (assoc 'org result)))) + + (setq result (icalendar--parse-summary-and-rest + "SUM sum DES des LOC loc ORG org STA sta URL url CLA cla")) + (should (string= "des" (cdr (assoc 'des result)))) + (should (string= "loc" (cdr (assoc 'loc result)))) + (should (string= "org" (cdr (assoc 'org result)))) + (should (string= "sta" (cdr (assoc 'sta result)))) + (should (string= "cla" (cdr (assoc 'cla result)))) + + (setq icalendar-import-format (lambda () "Hello world")) + (setq result (icalendar--parse-summary-and-rest + "blah blah ")) + (should (not result)) + )) + +(ert-deftest icalendar--decode-isodatetime () + "Test `icalendar--decode-isodatetime'." + (let ((tz (getenv "TZ")) + result) + (unwind-protect + (progn + ;; Use Eastern European Time (UTC+2, UTC+3 daylight saving) + (setenv "TZ" "EET-2EEST,M3.5.0/3,M10.5.0/4") + + (message "%s" (current-time-zone (encode-time 0 0 10 1 1 2013 0))) + (message "%s" (current-time-zone (encode-time 0 0 10 1 8 2013 0))) + + ;; testcase: no time zone in input -> keep time as is + ;; 1 Jan 2013 10:00 + (should (equal '(0 0 10 1 1 2013 2 nil 7200) + (icalendar--decode-isodatetime "20130101T100000"))) + ;; 1 Aug 2013 10:00 (DST) + (should (equal '(0 0 10 1 8 2013 4 t 10800) + (icalendar--decode-isodatetime "20130801T100000"))) + + ;; testcase: UTC time zone specifier in input -> convert to local time + ;; 31 Dec 2013 23:00 UTC -> 1 Jan 2013 01:00 EET + (should (equal '(0 0 1 1 1 2014 3 nil 7200) + (icalendar--decode-isodatetime "20131231T230000Z"))) + ;; 1 Aug 2013 10:00 UTC -> 1 Aug 2013 13:00 EEST + (should (equal '(0 0 13 1 8 2013 4 t 10800) + (icalendar--decode-isodatetime "20130801T100000Z"))) + + ) + ;; restore time-zone even if something went terribly wrong + (setenv "TZ" tz))) ) + +;; ====================================================================== +;; Export tests +;; ====================================================================== + +(defun icalendar-tests--test-export (input-iso input-european input-american + expected-output &optional alarms) + "Perform an export test. +Argument INPUT-ISO iso style diary string. +Argument INPUT-EUROPEAN european style diary string. +Argument INPUT-AMERICAN american style diary string. +Argument EXPECTED-OUTPUT expected iCalendar result string. +Optional argument ALARMS the value of `icalendar-export-alarms' for this test. + +European style input data must use german month names. American +and ISO style input data must use english month names." + (let ((tz (getenv "TZ")) + (calendar-date-style 'iso) + (icalendar-recurring-start-year 2000) + (icalendar-export-alarms alarms)) + (unwind-protect + (progn +;;; (message "Current time zone: %s" (current-time-zone)) + ;; Use this form so as not to rely on system tz database. + ;; Eg hydra.nixos.org. + (setenv "TZ" "CET-1CEST,M3.5.0/2,M10.5.0/3") +;;; (message "Current time zone: %s" (current-time-zone)) + (when input-iso + (let ((calendar-month-name-array + ["January" "February" "March" "April" "May" "June" "July" "August" + "September" "October" "November" "December"]) + (calendar-day-name-array + ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" + "Saturday"])) + (setq calendar-date-style 'iso) + (icalendar-tests--do-test-export input-iso expected-output))) + (when input-european + (let ((calendar-month-name-array + ["Januar" "Februar" "März" "April" "Mai" "Juni" "Juli" "August" + "September" "Oktober" "November" "Dezember"]) + (calendar-day-name-array + ["Sonntag" "Montag" "Dienstag" "Mittwoch" "Donnerstag" "Freitag" + "Samstag"])) + (setq calendar-date-style 'european) + (icalendar-tests--do-test-export input-european expected-output))) + (when input-american + (let ((calendar-month-name-array + ["January" "February" "March" "April" "May" "June" "July" "August" + "September" "October" "November" "December"]) + (calendar-day-name-array + ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" + "Saturday"])) + (setq calendar-date-style 'american) + (icalendar-tests--do-test-export input-american expected-output)))) + ;; restore time-zone even if something went terribly wrong + (setenv "TZ" tz)))) + +(defun icalendar-tests--do-test-export (input expected-output) + "Actually perform export test. +Argument INPUT input diary string. +Argument EXPECTED-OUTPUT expected iCalendar result string." + (let ((temp-file (make-temp-file "icalendar-tests-ics"))) + (unwind-protect + (progn + (with-temp-buffer + (insert input) + (icalendar-export-region (point-min) (point-max) temp-file)) + (save-excursion + (find-file temp-file) + (goto-char (point-min)) + (cond (expected-output + (should (re-search-forward "^\\s-*BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +UID:emacs[0-9]+ +\\(\\(.\\|\n\\)+\\) +END:VEVENT +END:VCALENDAR +\\s-*$" + nil t)) + (should (string-match + (concat "^\\s-*" + (regexp-quote (buffer-substring-no-properties + (match-beginning 1) (match-end 1))) + "\\s-*$") + expected-output))) + (t + (should (re-search-forward "^\\s-*BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +END:VCALENDAR +\\s-*$" + nil t)))))) + ;; cleanup!! + (kill-buffer (find-buffer-visiting temp-file)) + (delete-file temp-file)))) + +(ert-deftest icalendar-export-ordinary-no-time () + "Perform export test." + + (let ((icalendar-export-hidden-diary-entries nil)) + (icalendar-tests--test-export + "&2000 Oct 3 ordinary no time " + "&3 Okt 2000 ordinary no time " + "&Oct 3 2000 ordinary no time " + nil)) + + (icalendar-tests--test-export + "2000 Oct 3 ordinary no time " + "3 Okt 2000 ordinary no time " + "Oct 3 2000 ordinary no time " + "DTSTART;VALUE=DATE:20001003 +DTEND;VALUE=DATE:20001004 +SUMMARY:ordinary no time +")) + +(ert-deftest icalendar-export-ordinary () + "Perform export test." + + (icalendar-tests--test-export + "2000 Oct 3 16:30 ordinary with time" + "3 Okt 2000 16:30 ordinary with time" + "Oct 3 2000 16:30 ordinary with time" + "DTSTART;VALUE=DATE-TIME:20001003T163000 +DTEND;VALUE=DATE-TIME:20001003T173000 +SUMMARY:ordinary with time +") + (icalendar-tests--test-export + "2000 10 3 16:30 ordinary with time 2" + "3 10 2000 16:30 ordinary with time 2" + "10 3 2000 16:30 ordinary with time 2" + "DTSTART;VALUE=DATE-TIME:20001003T163000 +DTEND;VALUE=DATE-TIME:20001003T173000 +SUMMARY:ordinary with time 2 +") + + (icalendar-tests--test-export + "2000/10/3 16:30 ordinary with time 3" + "3/10/2000 16:30 ordinary with time 3" + "10/3/2000 16:30 ordinary with time 3" + "DTSTART;VALUE=DATE-TIME:20001003T163000 +DTEND;VALUE=DATE-TIME:20001003T173000 +SUMMARY:ordinary with time 3 +")) + +(ert-deftest icalendar-export-multiline () + "Perform export test." + + ;; multiline -- FIXME!!! + (icalendar-tests--test-export + "2000 October 3 16:30 multiline + 17:30 multiline continued FIXME" + "3 Oktober 2000 16:30 multiline + 17:30 multiline continued FIXME" + "October 3 2000 16:30 multiline + 17:30 multiline continued FIXME" + "DTSTART;VALUE=DATE-TIME:20001003T163000 +DTEND;VALUE=DATE-TIME:20001003T173000 +SUMMARY:multiline +DESCRIPTION: + 17:30 multiline continued FIXME +")) + +(ert-deftest icalendar-export-weekly-by-day () + "Perform export test." + + ;; weekly by day + (icalendar-tests--test-export + "Monday 1:30pm weekly by day with start time" + "Montag 13:30 weekly by day with start time" + "Monday 1:30pm weekly by day with start time" + "DTSTART;VALUE=DATE-TIME:20000103T133000 +DTEND;VALUE=DATE-TIME:20000103T143000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO +SUMMARY:weekly by day with start time +") + + (icalendar-tests--test-export + "Monday 13:30-15:00 weekly by day with start and end time" + "Montag 13:30-15:00 weekly by day with start and end time" + "Monday 01:30pm-03:00pm weekly by day with start and end time" + "DTSTART;VALUE=DATE-TIME:20000103T133000 +DTEND;VALUE=DATE-TIME:20000103T150000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO +SUMMARY:weekly by day with start and end time +")) + +(ert-deftest icalendar-export-yearly () + "Perform export test." + ;; yearly + (icalendar-tests--test-export + "may 1 yearly no time" + "1 Mai yearly no time" + "may 1 yearly no time" + "DTSTART;VALUE=DATE:19000501 +DTEND;VALUE=DATE:19000502 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=5;BYMONTHDAY=1 +SUMMARY:yearly no time +")) + +(ert-deftest icalendar-export-anniversary () + "Perform export test." + ;; anniversaries + (icalendar-tests--test-export + "%%(diary-anniversary 1989 10 3) anniversary no time" + "%%(diary-anniversary 3 10 1989) anniversary no time" + "%%(diary-anniversary 10 3 1989) anniversary no time" + "DTSTART;VALUE=DATE:19891003 +DTEND;VALUE=DATE:19891004 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=10;BYMONTHDAY=03 +SUMMARY:anniversary no time +") + (icalendar-tests--test-export + "%%(diary-anniversary 1989 10 3) 19:00-20:00 anniversary with time" + "%%(diary-anniversary 3 10 1989) 19:00-20:00 anniversary with time" + "%%(diary-anniversary 10 3 1989) 19:00-20:00 anniversary with time" + "DTSTART;VALUE=DATE-TIME:19891003T190000 +DTEND;VALUE=DATE-TIME:19891004T200000 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=10;BYMONTHDAY=03 +SUMMARY:anniversary with time +")) + +(ert-deftest icalendar-export-block () + "Perform export test." + ;; block + (icalendar-tests--test-export + "%%(diary-block 2001 6 18 2001 7 6) block no time" + "%%(diary-block 18 6 2001 6 7 2001) block no time" + "%%(diary-block 6 18 2001 7 6 2001) block no time" + "DTSTART;VALUE=DATE:20010618 +DTEND;VALUE=DATE:20010707 +SUMMARY:block no time +") + (icalendar-tests--test-export + "%%(diary-block 2001 6 18 2001 7 6) 13:00-17:00 block with time" + "%%(diary-block 18 6 2001 6 7 2001) 13:00-17:00 block with time" + "%%(diary-block 6 18 2001 7 6 2001) 13:00-17:00 block with time" + "DTSTART;VALUE=DATE-TIME:20010618T130000 +DTEND;VALUE=DATE-TIME:20010618T170000 +RRULE:FREQ=DAILY;INTERVAL=1;UNTIL=20010706 +SUMMARY:block with time +") + (icalendar-tests--test-export + "%%(diary-block 2001 6 18 2001 7 6) 13:00 block no end time" + "%%(diary-block 18 6 2001 6 7 2001) 13:00 block no end time" + "%%(diary-block 6 18 2001 7 6 2001) 13:00 block no end time" + "DTSTART;VALUE=DATE-TIME:20010618T130000 +DTEND;VALUE=DATE-TIME:20010618T140000 +RRULE:FREQ=DAILY;INTERVAL=1;UNTIL=20010706 +SUMMARY:block no end time +")) + +(ert-deftest icalendar-export-alarms () + "Perform export test with different settings for exporting alarms." + ;; no alarm + (icalendar-tests--test-export + "2014 Nov 17 19:30 no alarm" + "17 Nov 2014 19:30 no alarm" + "Nov 17 2014 19:30 no alarm" + "DTSTART;VALUE=DATE-TIME:20141117T193000 +DTEND;VALUE=DATE-TIME:20141117T203000 +SUMMARY:no alarm +" + nil) + + ;; 10 minutes in advance, audio + (icalendar-tests--test-export + "2014 Nov 17 19:30 audio alarm" + "17 Nov 2014 19:30 audio alarm" + "Nov 17 2014 19:30 audio alarm" + "DTSTART;VALUE=DATE-TIME:20141117T193000 +DTEND;VALUE=DATE-TIME:20141117T203000 +SUMMARY:audio alarm +BEGIN:VALARM +ACTION:AUDIO +TRIGGER:-PT10M +END:VALARM +" + '(10 ((audio)))) + + ;; 20 minutes in advance, display + (icalendar-tests--test-export + "2014 Nov 17 19:30 display alarm" + "17 Nov 2014 19:30 display alarm" + "Nov 17 2014 19:30 display alarm" + "DTSTART;VALUE=DATE-TIME:20141117T193000 +DTEND;VALUE=DATE-TIME:20141117T203000 +SUMMARY:display alarm +BEGIN:VALARM +ACTION:DISPLAY +TRIGGER:-PT20M +DESCRIPTION:display alarm +END:VALARM +" + '(20 ((display)))) + + ;; 66 minutes in advance, email + (icalendar-tests--test-export + "2014 Nov 17 19:30 email alarm" + "17 Nov 2014 19:30 email alarm" + "Nov 17 2014 19:30 email alarm" + "DTSTART;VALUE=DATE-TIME:20141117T193000 +DTEND;VALUE=DATE-TIME:20141117T203000 +SUMMARY:email alarm +BEGIN:VALARM +ACTION:EMAIL +TRIGGER:-PT66M +DESCRIPTION:email alarm +SUMMARY:email alarm +ATTENDEE:MAILTO:att.one@email.com +ATTENDEE:MAILTO:att.two@email.com +END:VALARM +" + '(66 ((email ("att.one@email.com" "att.two@email.com"))))) + + ;; 2 minutes in advance, all alarms + (icalendar-tests--test-export + "2014 Nov 17 19:30 all alarms" + "17 Nov 2014 19:30 all alarms" + "Nov 17 2014 19:30 all alarms" + "DTSTART;VALUE=DATE-TIME:20141117T193000 +DTEND;VALUE=DATE-TIME:20141117T203000 +SUMMARY:all alarms +BEGIN:VALARM +ACTION:EMAIL +TRIGGER:-PT2M +DESCRIPTION:all alarms +SUMMARY:all alarms +ATTENDEE:MAILTO:att.one@email.com +ATTENDEE:MAILTO:att.two@email.com +END:VALARM +BEGIN:VALARM +ACTION:AUDIO +TRIGGER:-PT2M +END:VALARM +BEGIN:VALARM +ACTION:DISPLAY +TRIGGER:-PT2M +DESCRIPTION:all alarms +END:VALARM +" + '(2 ((email ("att.one@email.com" "att.two@email.com")) (audio) (display))))) + +;; ====================================================================== +;; Import tests +;; ====================================================================== + +(defun icalendar-tests--test-import (input expected-iso expected-european + expected-american) + "Perform import test. +Argument INPUT icalendar event string. +Argument EXPECTED-ISO expected iso style diary string. +Argument EXPECTED-EUROPEAN expected european style diary string. +Argument EXPECTED-AMERICAN expected american style diary string. +During import test the timezone is set to Central European Time." + (let ((timezone (getenv "TZ"))) + (unwind-protect + (progn + ;; Use this form so as not to rely on system tz database. + ;; Eg hydra.nixos.org. + (setenv "TZ" "CET-1CEST,M3.5.0/2,M10.5.0/3") + (with-temp-buffer + (if (string-match "^BEGIN:VCALENDAR" input) + (insert input) + (insert "BEGIN:VCALENDAR\nPRODID:-//Emacs//NONSGML icalendar.el//EN\n") + (insert "VERSION:2.0\nBEGIN:VEVENT\n") + (insert input) + (unless (eq (char-before) ?\n) + (insert "\n")) + (insert "END:VEVENT\nEND:VCALENDAR\n")) + (let ((icalendar-import-format "%s%d%l%o%t%u%c%U") + (icalendar-import-format-summary "%s") + (icalendar-import-format-location "\n Location: %s") + (icalendar-import-format-description "\n Desc: %s") + (icalendar-import-format-organizer "\n Organizer: %s") + (icalendar-import-format-status "\n Status: %s") + (icalendar-import-format-url "\n URL: %s") + (icalendar-import-format-class "\n Class: %s") + (icalendar-import-format-uid "\n UID: %s") + calendar-date-style) + (when expected-iso + (setq calendar-date-style 'iso) + (icalendar-tests--do-test-import input expected-iso)) + (when expected-european + (setq calendar-date-style 'european) + (icalendar-tests--do-test-import input expected-european)) + (when expected-american + (setq calendar-date-style 'american) + (icalendar-tests--do-test-import input expected-american))))) + (setenv "TZ" timezone)))) + +(defun icalendar-tests--do-test-import (input expected-output) + "Actually perform import test. +Argument INPUT input icalendar string. +Argument EXPECTED-OUTPUT expected diary string." + (let ((temp-file (make-temp-file "icalendar-test-diary"))) + ;; Test the Catch-the-mysterious-coding-header logic below. + ;; Ruby-mode adds an after-save-hook which inserts the header! + ;; (save-excursion + ;; (find-file temp-file) + ;; (ruby-mode)) + (icalendar-import-buffer temp-file t t) + (save-excursion + (find-file temp-file) + ;; Check for the mysterious "# coding: ..." header, remove it + ;; and give a shout + (goto-char (point-min)) + (when (re-search-forward "# coding: .*?\n" nil t) + (message (concat "%s\n" + "Found mysterious \"# coding ...\" header! Removing it.\n" + "Current Modes: %s, %s\n" + "Current test: %s\n" + "%s") + (make-string 70 ?*) + major-mode + minor-mode-list + (ert-running-test) + (make-string 70 ?*)) + (buffer-disable-undo) + (replace-match "") + (set-buffer-modified-p nil)) + + (let ((result (buffer-substring-no-properties (point-min) (point-max)))) + (should (string= expected-output result))) + (kill-buffer (find-buffer-visiting temp-file)) + (delete-file temp-file)))) + +(ert-deftest icalendar-import-non-recurring () + "Perform standard import tests." + (icalendar-tests--test-import + "SUMMARY:non-recurring +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000" + "&2003/9/19 09:00-11:30 non-recurring\n" + "&19/9/2003 09:00-11:30 non-recurring\n" + "&9/19/2003 09:00-11:30 non-recurring\n") + (icalendar-tests--test-import + "SUMMARY:non-recurring allday +DTSTART;VALUE=DATE-TIME:20030919" + "&2003/9/19 non-recurring allday\n" + "&19/9/2003 non-recurring allday\n" + "&9/19/2003 non-recurring allday\n") + (icalendar-tests--test-import + ;; Checkdoc removes trailing blanks. Therefore: format! + (format "%s\n%s\n%s" "SUMMARY:long " " summary" + "DTSTART;VALUE=DATE:20030919") + "&2003/9/19 long summary\n" + "&19/9/2003 long summary\n" + "&9/19/2003 long summary\n") + (icalendar-tests--test-import + "UID:748f2da0-0d9b-11d8-97af-b4ec8686ea61 +SUMMARY:Sommerferien +STATUS:TENTATIVE +CLASS:PRIVATE +X-MOZILLA-ALARM-DEFAULT-UNITS:Minuten +X-MOZILLA-RECUR-DEFAULT-INTERVAL:0 +DTSTART;VALUE=DATE:20040719 +DTEND;VALUE=DATE:20040828 +DTSTAMP:20031103T011641Z +" + "&%%(and (diary-block 2004 7 19 2004 8 27)) Sommerferien + Status: TENTATIVE + Class: PRIVATE + UID: 748f2da0-0d9b-11d8-97af-b4ec8686ea61 +" + "&%%(and (diary-block 19 7 2004 27 8 2004)) Sommerferien + Status: TENTATIVE + Class: PRIVATE + UID: 748f2da0-0d9b-11d8-97af-b4ec8686ea61 +" + "&%%(and (diary-block 7 19 2004 8 27 2004)) Sommerferien + Status: TENTATIVE + Class: PRIVATE + UID: 748f2da0-0d9b-11d8-97af-b4ec8686ea61 +") + (icalendar-tests--test-import + "UID + :04979712-3902-11d9-93dd-8f9f4afe08da +SUMMARY + :folded summary +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + :20041123T140000 +DTEND + :20041123T143000 +DTSTAMP + :20041118T013430Z +LAST-MODIFIED + :20041118T013640Z +" + "&2004/11/23 14:00-14:30 folded summary + Status: TENTATIVE + Class: PRIVATE + UID: 04979712-3902-11d9-93dd-8f9f4afe08da\n" + "&23/11/2004 14:00-14:30 folded summary + Status: TENTATIVE + Class: PRIVATE + UID: 04979712-3902-11d9-93dd-8f9f4afe08da\n" + "&11/23/2004 14:00-14:30 folded summary + Status: TENTATIVE + Class: PRIVATE + UID: 04979712-3902-11d9-93dd-8f9f4afe08da\n") + + (icalendar-tests--test-import + "UID + :6161a312-3902-11d9-b512-f764153bb28b +SUMMARY + :another example +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + :20041123T144500 +DTEND + :20041123T154500 +DTSTAMP + :20041118T013641Z +" + "&2004/11/23 14:45-15:45 another example + Status: TENTATIVE + Class: PRIVATE + UID: 6161a312-3902-11d9-b512-f764153bb28b\n" + "&23/11/2004 14:45-15:45 another example + Status: TENTATIVE + Class: PRIVATE + UID: 6161a312-3902-11d9-b512-f764153bb28b\n" + "&11/23/2004 14:45-15:45 another example + Status: TENTATIVE + Class: PRIVATE + UID: 6161a312-3902-11d9-b512-f764153bb28b\n")) + +(ert-deftest icalendar-import-rrule () + (icalendar-tests--test-import + "SUMMARY:rrule daily +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY; +" + "&%%(and (diary-cyclic 1 2003 9 19)) 09:00-11:30 rrule daily\n" + "&%%(and (diary-cyclic 1 19 9 2003)) 09:00-11:30 rrule daily\n" + "&%%(and (diary-cyclic 1 9 19 2003)) 09:00-11:30 rrule daily\n") + ;; RRULE examples + (icalendar-tests--test-import + "SUMMARY:rrule daily +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY;INTERVAL=2 +" + "&%%(and (diary-cyclic 2 2003 9 19)) 09:00-11:30 rrule daily\n" + "&%%(and (diary-cyclic 2 19 9 2003)) 09:00-11:30 rrule daily\n" + "&%%(and (diary-cyclic 2 9 19 2003)) 09:00-11:30 rrule daily\n") + (icalendar-tests--test-import + "SUMMARY:rrule daily with exceptions +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY;INTERVAL=2 +EXDATE:20030921,20030925 +" + "&%%(and (not (diary-date 2003 9 25)) (not (diary-date 2003 9 21)) (diary-cyclic 2 2003 9 19)) 09:00-11:30 rrule daily with exceptions\n" + "&%%(and (not (diary-date 25 9 2003)) (not (diary-date 21 9 2003)) (diary-cyclic 2 19 9 2003)) 09:00-11:30 rrule daily with exceptions\n" + "&%%(and (not (diary-date 9 25 2003)) (not (diary-date 9 21 2003)) (diary-cyclic 2 9 19 2003)) 09:00-11:30 rrule daily with exceptions\n") + (icalendar-tests--test-import + "SUMMARY:rrule weekly +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=WEEKLY; +" + "&%%(and (diary-cyclic 7 2003 9 19)) 09:00-11:30 rrule weekly\n" + "&%%(and (diary-cyclic 7 19 9 2003)) 09:00-11:30 rrule weekly\n" + "&%%(and (diary-cyclic 7 9 19 2003)) 09:00-11:30 rrule weekly\n") + (icalendar-tests--test-import + "SUMMARY:rrule monthly no end +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=MONTHLY; +" + "&%%(and (diary-date t t 19) (diary-block 2003 9 19 9999 1 1)) 09:00-11:30 rrule monthly no end\n" + "&%%(and (diary-date 19 t t) (diary-block 19 9 2003 1 1 9999)) 09:00-11:30 rrule monthly no end\n" + "&%%(and (diary-date t 19 t) (diary-block 9 19 2003 1 1 9999)) 09:00-11:30 rrule monthly no end\n") + (icalendar-tests--test-import + "SUMMARY:rrule monthly with end +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=MONTHLY;UNTIL=20050819; +" + "&%%(and (diary-date t t 19) (diary-block 2003 9 19 2005 8 19)) 09:00-11:30 rrule monthly with end\n" + "&%%(and (diary-date 19 t t) (diary-block 19 9 2003 19 8 2005)) 09:00-11:30 rrule monthly with end\n" + "&%%(and (diary-date t 19 t) (diary-block 9 19 2003 8 19 2005)) 09:00-11:30 rrule monthly with end\n") + (icalendar-tests--test-import + "DTSTART;VALUE=DATE:20040815 +DTEND;VALUE=DATE:20040816 +SUMMARY:Maria Himmelfahrt +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=8 +" + "&%%(and (diary-anniversary 2004 8 15)) Maria Himmelfahrt\n" + "&%%(and (diary-anniversary 15 8 2004)) Maria Himmelfahrt\n" + "&%%(and (diary-anniversary 8 15 2004)) Maria Himmelfahrt\n") + (icalendar-tests--test-import + "SUMMARY:rrule yearly +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=YEARLY;INTERVAL=2 +" + "&%%(and (diary-anniversary 2003 9 19)) 09:00-11:30 rrule yearly\n" ;FIXME + "&%%(and (diary-anniversary 19 9 2003)) 09:00-11:30 rrule yearly\n" ;FIXME + "&%%(and (diary-anniversary 9 19 2003)) 09:00-11:30 rrule yearly\n") ;FIXME + (icalendar-tests--test-import + "SUMMARY:rrule count daily short +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY;COUNT=1;INTERVAL=1 +" + "&%%(and (diary-cyclic 1 2003 9 19) (diary-block 2003 9 19 2003 9 19)) 09:00-11:30 rrule count daily short\n" + "&%%(and (diary-cyclic 1 19 9 2003) (diary-block 19 9 2003 19 9 2003)) 09:00-11:30 rrule count daily short\n" + "&%%(and (diary-cyclic 1 9 19 2003) (diary-block 9 19 2003 9 19 2003)) 09:00-11:30 rrule count daily short\n") + (icalendar-tests--test-import + "SUMMARY:rrule count daily long +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY;COUNT=14;INTERVAL=1 +" + "&%%(and (diary-cyclic 1 2003 9 19) (diary-block 2003 9 19 2003 10 2)) 09:00-11:30 rrule count daily long\n" + "&%%(and (diary-cyclic 1 19 9 2003) (diary-block 19 9 2003 2 10 2003)) 09:00-11:30 rrule count daily long\n" + "&%%(and (diary-cyclic 1 9 19 2003) (diary-block 9 19 2003 10 2 2003)) 09:00-11:30 rrule count daily long\n") + (icalendar-tests--test-import + "SUMMARY:rrule count bi-weekly 3 times +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=WEEKLY;COUNT=3;INTERVAL=2 +" + "&%%(and (diary-cyclic 14 2003 9 19) (diary-block 2003 9 19 2003 10 31)) 09:00-11:30 rrule count bi-weekly 3 times\n" + "&%%(and (diary-cyclic 14 19 9 2003) (diary-block 19 9 2003 31 10 2003)) 09:00-11:30 rrule count bi-weekly 3 times\n" + "&%%(and (diary-cyclic 14 9 19 2003) (diary-block 9 19 2003 10 31 2003)) 09:00-11:30 rrule count bi-weekly 3 times\n") + (icalendar-tests--test-import + "SUMMARY:rrule count monthly +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=MONTHLY;INTERVAL=1;COUNT=5 +" + "&%%(and (diary-date t t 19) (diary-block 2003 9 19 2004 1 19)) 09:00-11:30 rrule count monthly\n" + "&%%(and (diary-date 19 t t) (diary-block 19 9 2003 19 1 2004)) 09:00-11:30 rrule count monthly\n" + "&%%(and (diary-date t 19 t) (diary-block 9 19 2003 1 19 2004)) 09:00-11:30 rrule count monthly\n") + (icalendar-tests--test-import + "SUMMARY:rrule count every second month +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=MONTHLY;INTERVAL=2;COUNT=5 +" + "&%%(and (diary-date t t 19) (diary-block 2003 9 19 2004 5 19)) 09:00-11:30 rrule count every second month\n" ;FIXME + "&%%(and (diary-date 19 t t) (diary-block 19 9 2003 19 5 2004)) 09:00-11:30 rrule count every second month\n" ;FIXME + "&%%(and (diary-date t 19 t) (diary-block 9 19 2003 5 19 2004)) 09:00-11:30 rrule count every second month\n") ;FIXME + (icalendar-tests--test-import + "SUMMARY:rrule count yearly +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=YEARLY;INTERVAL=1;COUNT=5 +" + "&%%(and (diary-date t 9 19) (diary-block 2003 9 19 2007 9 19)) 09:00-11:30 rrule count yearly\n" + "&%%(and (diary-date 19 9 t) (diary-block 19 9 2003 19 9 2007)) 09:00-11:30 rrule count yearly\n" + "&%%(and (diary-date 9 19 t) (diary-block 9 19 2003 9 19 2007)) 09:00-11:30 rrule count yearly\n") + (icalendar-tests--test-import + "SUMMARY:rrule count every second year +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=YEARLY;INTERVAL=2;COUNT=5 +" + "&%%(and (diary-date t 9 19) (diary-block 2003 9 19 2011 9 19)) 09:00-11:30 rrule count every second year\n" ;FIXME!!! + "&%%(and (diary-date 19 9 t) (diary-block 19 9 2003 19 9 2011)) 09:00-11:30 rrule count every second year\n" ;FIXME!!! + "&%%(and (diary-date 9 19 t) (diary-block 9 19 2003 9 19 2011)) 09:00-11:30 rrule count every second year\n") ;FIXME!!! +) + +(ert-deftest icalendar-import-duration () + ;; duration + (icalendar-tests--test-import + "DTSTART;VALUE=DATE:20050217 +SUMMARY:duration +DURATION:P7D +" + "&%%(and (diary-block 2005 2 17 2005 2 23)) duration\n" + "&%%(and (diary-block 17 2 2005 23 2 2005)) duration\n" + "&%%(and (diary-block 2 17 2005 2 23 2005)) duration\n") + (icalendar-tests--test-import + "UID:20041127T183329Z-18215-1001-4536-49109@andromeda +DTSTAMP:20041127T183315Z +LAST-MODIFIED:20041127T183329 +SUMMARY:Urlaub +DTSTART;VALUE=DATE:20011221 +DTEND;VALUE=DATE:20011221 +RRULE:FREQ=DAILY;UNTIL=20011229;INTERVAL=1;WKST=SU +CLASS:PUBLIC +SEQUENCE:1 +CREATED:20041127T183329 +" + "&%%(and (diary-cyclic 1 2001 12 21) (diary-block 2001 12 21 2001 12 29)) Urlaub + Class: PUBLIC + UID: 20041127T183329Z-18215-1001-4536-49109@andromeda\n" + "&%%(and (diary-cyclic 1 21 12 2001) (diary-block 21 12 2001 29 12 2001)) Urlaub + Class: PUBLIC + UID: 20041127T183329Z-18215-1001-4536-49109@andromeda\n" + "&%%(and (diary-cyclic 1 12 21 2001) (diary-block 12 21 2001 12 29 2001)) Urlaub + Class: PUBLIC + UID: 20041127T183329Z-18215-1001-4536-49109@andromeda\n")) + +(ert-deftest icalendar-import-bug-6766 () + ;;bug#6766 -- multiple byday values in a weekly rrule + (icalendar-tests--test-import +"CLASS:PUBLIC +DTEND;TZID=America/New_York:20100421T120000 +DTSTAMP:20100525T141214Z +DTSTART;TZID=America/New_York:20100421T113000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO,WE,TH,FR +SEQUENCE:1 +STATUS:CONFIRMED +SUMMARY:Scrum +TRANSP:OPAQUE +UID:8814e3f9-7482-408f-996c-3bfe486a1262 +END:VEVENT +BEGIN:VEVENT +CLASS:PUBLIC +DTSTAMP:20100525T141214Z +DTSTART;VALUE=DATE:20100422 +DTEND;VALUE=DATE:20100423 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=TU,TH +SEQUENCE:1 +SUMMARY:Tues + Thurs thinking +TRANSP:OPAQUE +UID:8814e3f9-7482-408f-996c-3bfe486a1263 +" +"&%%(and (memq (calendar-day-of-week date) '(1 3 4 5)) (diary-cyclic 1 2010 4 21)) 11:30-12:00 Scrum + Status: CONFIRMED + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1262 +&%%(and (memq (calendar-day-of-week date) '(2 4)) (diary-cyclic 1 2010 4 22)) Tues + Thurs thinking + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1263 +" +"&%%(and (memq (calendar-day-of-week date) '(1 3 4 5)) (diary-cyclic 1 21 4 2010)) 11:30-12:00 Scrum + Status: CONFIRMED + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1262 +&%%(and (memq (calendar-day-of-week date) '(2 4)) (diary-cyclic 1 22 4 2010)) Tues + Thurs thinking + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1263 +" +"&%%(and (memq (calendar-day-of-week date) '(1 3 4 5)) (diary-cyclic 1 4 21 2010)) 11:30-12:00 Scrum + Status: CONFIRMED + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1262 +&%%(and (memq (calendar-day-of-week date) '(2 4)) (diary-cyclic 1 4 22 2010)) Tues + Thurs thinking + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1263 +")) + +(ert-deftest icalendar-import-bug-24199 () + ;;bug#24199 -- monthly rule with byday-clause + (icalendar-tests--test-import +" +SUMMARY:Summary +DESCRIPTION:Desc +LOCATION:Loc +DTSTART:20151202T124600 +DTEND:20151202T160000 +RRULE:FREQ=MONTHLY;BYDAY=1WE;INTERVAL=1 +EXDATE:20160106T114600Z +EXDATE:20160203T114600Z +EXDATE:20160302T114600Z +EXDATE:20160504T104600Z +EXDATE:20160601T104600Z +CLASS:DEFAULT +TRANSP:OPAQUE +BEGIN:VALARM +ACTION:DISPLAY +TRIGGER;VALUE=DURATION:-PT3H +END:VALARM +LAST-MODIFIED:20160805T191040Z +UID:9188710a-08a7-4061-bae3-d4cf4972599a +" +"&%%(and (not (diary-date 2016 1 6)) (not (diary-date 2016 2 3)) (not (diary-date 2016 3 2)) (not (diary-date 2016 5 4)) (not (diary-date 2016 6 1)) (diary-float t 3 1) (diary-block 2015 12 2 9999 1 1)) 12:46-16:00 Summary + Desc: Desc + Location: Loc + Class: DEFAULT + UID: 9188710a-08a7-4061-bae3-d4cf4972599a +" +"&%%(and (not (diary-date 6 1 2016)) (not (diary-date 3 2 2016)) (not (diary-date 2 3 2016)) (not (diary-date 4 5 2016)) (not (diary-date 1 6 2016)) (diary-float t 3 1) (diary-block 2 12 2015 1 1 9999)) 12:46-16:00 Summary + Desc: Desc + Location: Loc + Class: DEFAULT + UID: 9188710a-08a7-4061-bae3-d4cf4972599a +" +"&%%(and (not (diary-date 1 6 2016)) (not (diary-date 2 3 2016)) (not (diary-date 3 2 2016)) (not (diary-date 5 4 2016)) (not (diary-date 6 1 2016)) (diary-float t 3 1) (diary-block 12 2 2015 1 1 9999)) 12:46-16:00 Summary + Desc: Desc + Location: Loc + Class: DEFAULT + UID: 9188710a-08a7-4061-bae3-d4cf4972599a +" +)) + +(ert-deftest icalendar-import-multiple-vcalendars () + (icalendar-tests--test-import + "DTSTART;VALUE=DATE:20110723 +SUMMARY:event-1 +" + "&2011/7/23 event-1\n" + "&23/7/2011 event-1\n" + "&7/23/2011 event-1\n") + + (icalendar-tests--test-import + "BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0\nBEGIN:VEVENT +DTSTART;VALUE=DATE:20110723 +SUMMARY:event-1 +END:VEVENT +END:VCALENDAR +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +DTSTART;VALUE=DATE:20110724 +SUMMARY:event-2 +END:VEVENT +END:VCALENDAR +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +DTSTART;VALUE=DATE:20110725 +SUMMARY:event-3a +END:VEVENT +BEGIN:VEVENT +DTSTART;VALUE=DATE:20110725 +SUMMARY:event-3b +END:VEVENT +END:VCALENDAR +" + "&2011/7/23 event-1\n&2011/7/24 event-2\n&2011/7/25 event-3a\n&2011/7/25 event-3b\n" + "&23/7/2011 event-1\n&24/7/2011 event-2\n&25/7/2011 event-3a\n&25/7/2011 event-3b\n" + "&7/23/2011 event-1\n&7/24/2011 event-2\n&7/25/2011 event-3a\n&7/25/2011 event-3b\n")) + +(ert-deftest icalendar-import-with-uid () + "Perform import test with uid." + (icalendar-tests--test-import + "UID:1234567890uid +SUMMARY:non-recurring +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000" + "&2003/9/19 09:00-11:30 non-recurring\n UID: 1234567890uid\n" + "&19/9/2003 09:00-11:30 non-recurring\n UID: 1234567890uid\n" + "&9/19/2003 09:00-11:30 non-recurring\n UID: 1234567890uid\n")) + +(ert-deftest icalendar-import-with-timezone () + ;; This is known to fail on MS-Windows, because the test assumes + ;; Posix features of specifying DST rules. + :expected-result (if (memq system-type '(windows-nt ms-dos)) + :failed + :passed) + ;; bug#11473 + (icalendar-tests--test-import + "BEGIN:VCALENDAR +BEGIN:VTIMEZONE +TZID:fictional, nonexistent, arbitrary +BEGIN:STANDARD +DTSTART:20100101T000000 +TZOFFSETFROM:+0200 +TZOFFSETTO:-0200 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=1SU;BYMONTH=01 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:20101201T000000 +TZOFFSETFROM:-0200 +TZOFFSETTO:+0200 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=1SU;BYMONTH=11 +END:DAYLIGHT +END:VTIMEZONE +BEGIN:VEVENT +SUMMARY:standardtime +DTSTART;TZID=\"fictional, nonexistent, arbitrary\":20120115T120000 +DTEND;TZID=\"fictional, nonexistent, arbitrary\":20120115T123000 +END:VEVENT +BEGIN:VEVENT +SUMMARY:daylightsavingtime +DTSTART;TZID=\"fictional, nonexistent, arbitrary\":20121215T120000 +DTEND;TZID=\"fictional, nonexistent, arbitrary\":20121215T123000 +END:VEVENT +END:VCALENDAR" + ;; "standardtime" begins first sunday in january and is 4 hours behind CET + ;; "daylightsavingtime" begins first sunday in november and is 1 hour before CET + "&2012/1/15 15:00-15:30 standardtime +&2012/12/15 11:00-11:30 daylightsavingtime +" + nil + nil) + ) +;; ====================================================================== +;; Cycle +;; ====================================================================== +(defun icalendar-tests--test-cycle (input) + "Perform cycle test. +Argument INPUT icalendar event string." + (with-temp-buffer + (if (string-match "^BEGIN:VCALENDAR" input) + (insert input) + (insert "BEGIN:VCALENDAR\nPRODID:-//Emacs//NONSGML icalendar.el//EN\n") + (insert "VERSION:2.0\nBEGIN:VEVENT\n") + (insert input) + (unless (eq (char-before) ?\n) + (insert "\n")) + (insert "END:VEVENT\nEND:VCALENDAR\n")) + (let ((icalendar-import-format "%s%d%l%o%t%u%c%U") + (icalendar-import-format-summary "%s") + (icalendar-import-format-location "\n Location: %s") + (icalendar-import-format-description "\n Desc: %s") + (icalendar-import-format-organizer "\n Organizer: %s") + (icalendar-import-format-status "\n Status: %s") + (icalendar-import-format-url "\n URL: %s") + (icalendar-import-format-class "\n Class: %s") + (icalendar-import-format-class "\n UID: %s") + (icalendar-export-alarms nil)) + (dolist (calendar-date-style '(iso european american)) + (icalendar-tests--do-test-cycle))))) + +(defun icalendar-tests--do-test-cycle () + "Actually perform import/export cycle test." + (let ((temp-diary (make-temp-file "icalendar-test-diary")) + (temp-ics (make-temp-file "icalendar-test-ics")) + (org-input (buffer-substring-no-properties (point-min) (point-max)))) + + (unwind-protect + (progn + ;; step 1: import + (icalendar-import-buffer temp-diary t t) + + ;; step 2: export what was just imported + (save-excursion + (find-file temp-diary) + (icalendar-export-region (point-min) (point-max) temp-ics)) + + ;; compare the output of step 2 with the input of step 1 + (save-excursion + (find-file temp-ics) + (goto-char (point-min)) + ;;(when (re-search-forward "\nUID:.*\n" nil t) + ;;(replace-match "\n")) + (let ((cycled (buffer-substring-no-properties (point-min) (point-max)))) + (should (string= org-input cycled))))) + ;; clean up + (kill-buffer (find-buffer-visiting temp-diary)) + (with-current-buffer (find-buffer-visiting temp-ics) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer))) + (delete-file temp-diary) + (delete-file temp-ics)))) + +(ert-deftest icalendar-cycle () + "Perform cycling tests. +Take care to avoid auto-generated UIDs here." + (icalendar-tests--test-cycle + "UID:dummyuid +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +SUMMARY:Cycletest +") + (icalendar-tests--test-cycle + "UID:blah +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +SUMMARY:Cycletest +DESCRIPTION:beschreibung! +LOCATION:nowhere +ORGANIZER:ulf +") + (icalendar-tests--test-cycle + "UID:4711 +DTSTART;VALUE=DATE:19190909 +DTEND;VALUE=DATE:19190910 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=09;BYMONTHDAY=09 +SUMMARY:and diary-anniversary +")) + +;; ====================================================================== +;; Real world +;; ====================================================================== +(ert-deftest icalendar-real-world () + "Perform real-world tests, as gathered from problem reports." + ;; This is known to fail on MS-Windows, since it doesn't support DST + ;; specification with month and day. + :expected-result (if (memq system-type '(windows-nt ms-dos)) + :failed + :passed) + ;; 2003-05-29 + (icalendar-tests--test-import + "BEGIN:VCALENDAR +METHOD:REQUEST +PRODID:Microsoft CDO for Microsoft Exchange +VERSION:2.0 +BEGIN:VTIMEZONE +TZID:Kolkata, Chennai, Mumbai, New Delhi +X-MICROSOFT-CDO-TZID:23 +BEGIN:STANDARD +DTSTART:16010101T000000 +TZOFFSETFROM:+0530 +TZOFFSETTO:+0530 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T000000 +TZOFFSETFROM:+0530 +TZOFFSETTO:+0530 +END:DAYLIGHT +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20030509T043439Z +DTSTART;TZID=\"Kolkata, Chennai, Mumbai, New Delhi\":20030509T103000 +SUMMARY:On-Site Interview +UID:040000008200E00074C5B7101A82E0080000000080B6DE661216C301000000000000000 + 010000000DB823520692542408ED02D7023F9DFF9 +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN=\"Xxxxx + xxx Xxxxxxxxxxxx\":MAILTO:xxxxxxxx@xxxxxxx.com +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN=\"Yyyyyyy Y + yyyy\":MAILTO:yyyyyyy@yyyyyyy.com +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN=\"Zzzz Zzzz + zz\":MAILTO:zzzzzz@zzzzzzz.com +ORGANIZER;CN=\"Aaaaaa Aaaaa\":MAILTO:aaaaaaa@aaaaaaa.com +LOCATION:Cccc +DTEND;TZID=\"Kolkata, Chennai, Mumbai, New Delhi\":20030509T153000 +DESCRIPTION:10:30am - Blah +SEQUENCE:0 +PRIORITY:5 +CLASS: +CREATED:20030509T043439Z +LAST-MODIFIED:20030509T043459Z +STATUS:CONFIRMED +TRANSP:OPAQUE +X-MICROSOFT-CDO-BUSYSTATUS:BUSY +X-MICROSOFT-CDO-INSTTYPE:0 +X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY +X-MICROSOFT-CDO-ALLDAYEVENT:FALSE +X-MICROSOFT-CDO-IMPORTANCE:1 +X-MICROSOFT-CDO-OWNERAPPTID:126441427 +BEGIN:VALARM +ACTION:DISPLAY +DESCRIPTION:REMINDER +TRIGGER;RELATED=START:-PT00H15M00S +END:VALARM +END:VEVENT +END:VCALENDAR" + nil + "&9/5/2003 07:00-12:00 On-Site Interview + Desc: 10:30am - Blah + Location: Cccc + Organizer: MAILTO:aaaaaaa@aaaaaaa.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E0080000000080B6DE661216C301000000000000000010000000DB823520692542408ED02D7023F9DFF9 +" + "&5/9/2003 07:00-12:00 On-Site Interview + Desc: 10:30am - Blah + Location: Cccc + Organizer: MAILTO:aaaaaaa@aaaaaaa.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E0080000000080B6DE661216C301000000000000000010000000DB823520692542408ED02D7023F9DFF9 +") + + ;; created with http://apps.marudot.com/ical/ + (icalendar-tests--test-import + "BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//www.marudot.com//iCal Event Maker +X-WR-CALNAME:Test +CALSCALE:GREGORIAN +BEGIN:VTIMEZONE +TZID:Asia/Tehran +TZURL:http://tzurl.org/zoneinfo-outlook/Asia/Tehran +X-LIC-LOCATION:Asia/Tehran +BEGIN:STANDARD +TZOFFSETFROM:+0330 +TZOFFSETTO:+0330 +TZNAME:IRST +DTSTART:19700101T000000 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20141116T171439Z +UID:20141116T171439Z-678877132@marudot.com +DTSTART;TZID=\"Asia/Tehran\":20141116T070000 +DTEND;TZID=\"Asia/Tehran\":20141116T080000 +SUMMARY:NoDST +DESCRIPTION:Test event from timezone without DST +LOCATION:Everywhere +END:VEVENT +END:VCALENDAR" + nil + "&16/11/2014 04:30-05:30 NoDST + Desc: Test event from timezone without DST + Location: Everywhere + UID: 20141116T171439Z-678877132@marudot.com +" + "&11/16/2014 04:30-05:30 NoDST + Desc: Test event from timezone without DST + Location: Everywhere + UID: 20141116T171439Z-678877132@marudot.com +") + + + ;; 2003-06-18 a + (icalendar-tests--test-import + "DTSTAMP:20030618T195512Z +DTSTART;TZID=\"Mountain Time (US & Canada)\":20030623T110000 +SUMMARY:Dress Rehearsal for XXXX-XXXX +UID:040000008200E00074C5B7101A82E00800000000608AA7DA9835C301000000000000000 + 0100000007C3A6D65EE726E40B7F3D69A23BD567E +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN=\"AAAAA,AAA + AA (A-AAAAAAA,ex1)\":MAILTO:aaaaa_aaaaa@aaaaa.com +ORGANIZER;CN=\"ABCD,TECHTRAINING + (A-Americas,exgen1)\":MAILTO:xxx@xxxxx.com +LOCATION:555 or TN 555-5555 ID 5555 & NochWas (see below) +DTEND;TZID=\"Mountain Time (US & Canada)\":20030623T120000 +DESCRIPTION:753 Zeichen hier radiert +SEQUENCE:0 +PRIORITY:5 +CLASS: +CREATED:20030618T195518Z +LAST-MODIFIED:20030618T195527Z +STATUS:CONFIRMED +TRANSP:OPAQUE +X-MICROSOFT-CDO-BUSYSTATUS:BUSY +X-MICROSOFT-CDO-INSTTYPE:0 +X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY +X-MICROSOFT-CDO-ALLDAYEVENT:FALSE +X-MICROSOFT-CDO-IMPORTANCE:1 +X-MICROSOFT-CDO-OWNERAPPTID:1022519251 +BEGIN:VALARM +ACTION:DISPLAY +DESCRIPTION:REMINDER +TRIGGER;RELATED=START:-PT00H15M00S +END:VALARM" + nil + "&23/6/2003 11:00-12:00 Dress Rehearsal for XXXX-XXXX + Desc: 753 Zeichen hier radiert + Location: 555 or TN 555-5555 ID 5555 & NochWas (see below) + Organizer: MAILTO:xxx@xxxxx.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E +" + "&6/23/2003 11:00-12:00 Dress Rehearsal for XXXX-XXXX + Desc: 753 Zeichen hier radiert + Location: 555 or TN 555-5555 ID 5555 & NochWas (see below) + Organizer: MAILTO:xxx@xxxxx.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E +") + ;; 2003-06-18 b -- uses timezone + (icalendar-tests--test-import + "BEGIN:VCALENDAR +METHOD:REQUEST +PRODID:Microsoft CDO for Microsoft Exchange +VERSION:2.0 +BEGIN:VTIMEZONE +TZID:Mountain Time (US & Canada) +X-MICROSOFT-CDO-TZID:12 +BEGIN:STANDARD +DTSTART:16010101T020000 +TZOFFSETFROM:-0600 +TZOFFSETTO:-0700 +RRULE:FREQ=YEARLY;WKST=MO;INTERVAL=1;BYMONTH=10;BYDAY=-1SU +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T020000 +TZOFFSETFROM:-0700 +TZOFFSETTO:-0600 +RRULE:FREQ=YEARLY;WKST=MO;INTERVAL=1;BYMONTH=4;BYDAY=1SU +END:DAYLIGHT +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20030618T230323Z +DTSTART;TZID=\"Mountain Time (US & Canada)\":20030623T090000 +SUMMARY:Updated: Dress Rehearsal for ABC01-15 +UID:040000008200E00074C5B7101A82E00800000000608AA7DA9835C301000000000000000 + 0100000007C3A6D65EE726E40B7F3D69A23BD567E +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;X-REPLYTIME=20030618T20 + 0700Z;RSVP=TRUE;CN=\"AAAAA,AAAAAA +\(A-AAAAAAA,ex1)\":MAILTO:aaaaaa_aaaaa@aaaaa + .com +ORGANIZER;CN=\"ABCD,TECHTRAINING +\(A-Americas,exgen1)\":MAILTO:bbb@bbbbb.com +LOCATION:123 or TN 123-1234 ID abcd & SonstWo (see below) +DTEND;TZID=\"Mountain Time (US & Canada)\":20030623T100000 +DESCRIPTION:Viele Zeichen standen hier früher +SEQUENCE:0 +PRIORITY:5 +CLASS: +CREATED:20030618T230326Z +LAST-MODIFIED:20030618T230335Z +STATUS:CONFIRMED +TRANSP:OPAQUE +X-MICROSOFT-CDO-BUSYSTATUS:BUSY +X-MICROSOFT-CDO-INSTTYPE:0 +X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY +X-MICROSOFT-CDO-ALLDAYEVENT:FALSE +X-MICROSOFT-CDO-IMPORTANCE:1 +X-MICROSOFT-CDO-OWNERAPPTID:1022519251 +BEGIN:VALARM +ACTION:DISPLAY +DESCRIPTION:REMINDER +TRIGGER;RELATED=START:-PT00H15M00S +END:VALARM +END:VEVENT +END:VCALENDAR" + nil + "&23/6/2003 17:00-18:00 Updated: Dress Rehearsal for ABC01-15 + Desc: Viele Zeichen standen hier früher + Location: 123 or TN 123-1234 ID abcd & SonstWo (see below) + Organizer: MAILTO:bbb@bbbbb.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E +" + "&6/23/2003 17:00-18:00 Updated: Dress Rehearsal for ABC01-15 + Desc: Viele Zeichen standen hier früher + Location: 123 or TN 123-1234 ID abcd & SonstWo (see below) + Organizer: MAILTO:bbb@bbbbb.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E +") + ;; export 2004-10-28 block entries + (icalendar-tests--test-export + nil + nil + "-*- mode: text; fill-column: 256;-*- + +>>> block entries: + +%%(diary-block 11 8 2004 11 10 2004) Nov 8-10 aa +" + "DTSTART;VALUE=DATE:20041108 +DTEND;VALUE=DATE:20041111 +SUMMARY:Nov 8-10 aa") + + (icalendar-tests--test-export + nil + nil + "%%(diary-block 12 13 2004 12 17 2004) Dec 13-17 bb" + "DTSTART;VALUE=DATE:20041213 +DTEND;VALUE=DATE:20041218 +SUMMARY:Dec 13-17 bb") + + (icalendar-tests--test-export + nil + nil + "%%(diary-block 2 3 2005 2 4 2005) Feb 3-4 cc" + "DTSTART;VALUE=DATE:20050203 +DTEND;VALUE=DATE:20050205 +SUMMARY:Feb 3-4 cc") + + (icalendar-tests--test-export + nil + nil + "%%(diary-block 4 24 2005 4 29 2005) April 24-29 dd" + "DTSTART;VALUE=DATE:20050424 +DTEND;VALUE=DATE:20050430 +SUMMARY:April 24-29 dd +") + (icalendar-tests--test-export + nil + nil + "%%(diary-block 5 30 2005 6 1 2005) may 30 - June 1: ee" + "DTSTART;VALUE=DATE:20050530 +DTEND;VALUE=DATE:20050602 +SUMMARY:may 30 - June 1: ee") + + (icalendar-tests--test-export + nil + nil + "%%(diary-block 6 6 2005 6 8 2005) ff" + "DTSTART;VALUE=DATE:20050606 +DTEND;VALUE=DATE:20050609 +SUMMARY:ff") + + ;; export 2004-10-28 anniversary entries + (icalendar-tests--test-export + nil + nil + " +>>> anniversaries: + +%%(diary-anniversary 3 28 1991) aa birthday (%d years old)" + "DTSTART;VALUE=DATE:19910328 +DTEND;VALUE=DATE:19910329 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=03;BYMONTHDAY=28 +SUMMARY:aa birthday (%d years old) +") + + (icalendar-tests--test-export + nil + nil + "%%(diary-anniversary 5 17 1957) bb birthday (%d years old)" + "DTSTART;VALUE=DATE:19570517 +DTEND;VALUE=DATE:19570518 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=05;BYMONTHDAY=17 +SUMMARY:bb birthday (%d years old)") + + (icalendar-tests--test-export + nil + nil + "%%(diary-anniversary 6 8 1997) cc birthday (%d years old)" + "DTSTART;VALUE=DATE:19970608 +DTEND;VALUE=DATE:19970609 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=06;BYMONTHDAY=08 +SUMMARY:cc birthday (%d years old)") + + (icalendar-tests--test-export + nil + nil + "%%(diary-anniversary 7 22 1983) dd (%d years ago...!)" + "DTSTART;VALUE=DATE:19830722 +DTEND;VALUE=DATE:19830723 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=07;BYMONTHDAY=22 +SUMMARY:dd (%d years ago...!)") + + (icalendar-tests--test-export + nil + nil + "%%(diary-anniversary 8 1 1988) ee birthday (%d years old)" + "DTSTART;VALUE=DATE:19880801 +DTEND;VALUE=DATE:19880802 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=08;BYMONTHDAY=01 +SUMMARY:ee birthday (%d years old)") + + (icalendar-tests--test-export + nil + nil + "%%(diary-anniversary 9 21 1957) ff birthday (%d years old)" + "DTSTART;VALUE=DATE:19570921 +DTEND;VALUE=DATE:19570922 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=09;BYMONTHDAY=21 +SUMMARY:ff birthday (%d years old)") + + + ;; FIXME! + + ;; export 2004-10-28 monthly, weekly entries + + ;; (icalendar-tests--test-export + ;; nil + ;; " + ;; >>> ------------ monthly: + + ;; */27/* 10:00 blah blah" + ;; "xxx") + + (icalendar-tests--test-export + nil + nil + ">>> ------------ my week: + +Monday 13:00 MAC" + "DTSTART;VALUE=DATE-TIME:20000103T130000 +DTEND;VALUE=DATE-TIME:20000103T140000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO +SUMMARY:MAC") + + (icalendar-tests--test-export + nil + nil + "Monday 15:00 a1" + "DTSTART;VALUE=DATE-TIME:20000103T150000 +DTEND;VALUE=DATE-TIME:20000103T160000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO +SUMMARY:a1") + + + (icalendar-tests--test-export + nil + nil + "Monday 16:00-17:00 a2" + "DTSTART;VALUE=DATE-TIME:20000103T160000 +DTEND;VALUE=DATE-TIME:20000103T170000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO +SUMMARY:a2") + + (icalendar-tests--test-export + nil + nil + "Tuesday 11:30-13:00 a3" + "DTSTART;VALUE=DATE-TIME:20000104T113000 +DTEND;VALUE=DATE-TIME:20000104T130000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=TU +SUMMARY:a3") + + (icalendar-tests--test-export + nil + nil + "Tuesday 15:00 a4" + "DTSTART;VALUE=DATE-TIME:20000104T150000 +DTEND;VALUE=DATE-TIME:20000104T160000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=TU +SUMMARY:a4") + + (icalendar-tests--test-export + nil + nil + "Wednesday 13:00 a5" + "DTSTART;VALUE=DATE-TIME:20000105T130000 +DTEND;VALUE=DATE-TIME:20000105T140000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=WE +SUMMARY:a5") + + (icalendar-tests--test-export + nil + nil + "Wednesday 11:30-13:30 a6" + "DTSTART;VALUE=DATE-TIME:20000105T113000 +DTEND;VALUE=DATE-TIME:20000105T133000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=WE +SUMMARY:a6") + + (icalendar-tests--test-export + nil + nil + "Wednesday 15:00 s1" + "DTSTART;VALUE=DATE-TIME:20000105T150000 +DTEND;VALUE=DATE-TIME:20000105T160000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=WE +SUMMARY:s1") + + + ;; export 2004-10-28 regular entries + (icalendar-tests--test-export + nil + nil + " +>>> regular diary entries: + +Oct 12 2004, 14:00 Tue: [2004-10-12] q1" + "DTSTART;VALUE=DATE-TIME:20041012T140000 +DTEND;VALUE=DATE-TIME:20041012T150000 +SUMMARY:Tue: [2004-10-12] q1") + + ;; 2004-11-19 + (icalendar-tests--test-import + "BEGIN:VCALENDAR +VERSION + :2.0 +PRODID + :-//Mozilla.org/NONSGML Mozilla Calendar V1.0//EN +BEGIN:VEVENT +SUMMARY + :Jjjjj & Wwwww +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + :20041123T140000 +DTEND + :20041123T143000 +DTSTAMP + :20041118T013430Z +LAST-MODIFIED + :20041118T013640Z +END:VEVENT +BEGIN:VEVENT +SUMMARY + :BB Aaaaaaaa Bbbbb +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + :20041123T144500 +DTEND + :20041123T154500 +DTSTAMP + :20041118T013641Z +END:VEVENT +BEGIN:VEVENT +SUMMARY + :Hhhhhhhh +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + :20041123T110000 +DTEND + :20041123T120000 +DTSTAMP + :20041118T013831Z +END:VEVENT +BEGIN:VEVENT +SUMMARY + :MMM Aaaaaaaaa +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +X-MOZILLA-RECUR-DEFAULT-INTERVAL + :2 +RRULE + :FREQ=WEEKLY;INTERVAL=2;BYDAY=FR +DTSTART + :20041112T140000 +DTEND + :20041112T183000 +DTSTAMP + :20041118T014117Z +END:VEVENT +BEGIN:VEVENT +SUMMARY + :Rrrr/Cccccc ii Aaaaaaaa +DESCRIPTION + :Vvvvv Rrrr aaa Cccccc +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + ;VALUE=DATE + :20041119 +DTEND + ;VALUE=DATE + :20041120 +DTSTAMP + :20041118T013107Z +LAST-MODIFIED + :20041118T014203Z +END:VEVENT +BEGIN:VEVENT +SUMMARY + :Wwww aa hhhh +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +RRULE + :FREQ=WEEKLY;INTERVAL=1;BYDAY=MO +DTSTART + ;VALUE=DATE + :20041101 +DTEND + ;VALUE=DATE + :20041102 +DTSTAMP + :20041118T014045Z +LAST-MODIFIED + :20041118T023846Z +END:VEVENT +END:VCALENDAR +" + nil + "&23/11/2004 14:00-14:30 Jjjjj & Wwwww + Status: TENTATIVE + Class: PRIVATE +&23/11/2004 14:45-15:45 BB Aaaaaaaa Bbbbb + Status: TENTATIVE + Class: PRIVATE +&23/11/2004 11:00-12:00 Hhhhhhhh + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-cyclic 14 12 11 2004)) 14:00-18:30 MMM Aaaaaaaaa + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-block 19 11 2004 19 11 2004)) Rrrr/Cccccc ii Aaaaaaaa + Desc: Vvvvv Rrrr aaa Cccccc + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-cyclic 7 1 11 2004)) Wwww aa hhhh + Status: TENTATIVE + Class: PRIVATE +" + "&11/23/2004 14:00-14:30 Jjjjj & Wwwww + Status: TENTATIVE + Class: PRIVATE +&11/23/2004 14:45-15:45 BB Aaaaaaaa Bbbbb + Status: TENTATIVE + Class: PRIVATE +&11/23/2004 11:00-12:00 Hhhhhhhh + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-cyclic 14 11 12 2004)) 14:00-18:30 MMM Aaaaaaaaa + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-block 11 19 2004 11 19 2004)) Rrrr/Cccccc ii Aaaaaaaa + Desc: Vvvvv Rrrr aaa Cccccc + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-cyclic 7 11 1 2004)) Wwww aa hhhh + Status: TENTATIVE + Class: PRIVATE +") + + ;; 2004-09-09 pg + (icalendar-tests--test-export + "%%(diary-block 1 1 2004 4 1 2004) Urlaub" + nil + nil + "DTSTART;VALUE=DATE:20040101 +DTEND;VALUE=DATE:20040105 +SUMMARY:Urlaub") + + ;; 2004-10-25 pg + (icalendar-tests--test-export + nil + "5 11 2004 Bla Fasel" + nil + "DTSTART;VALUE=DATE:20041105 +DTEND;VALUE=DATE:20041106 +SUMMARY:Bla Fasel") + + ;; 2004-10-30 pg + (icalendar-tests--test-export + nil + "2 Nov 2004 15:00-16:30 Zahnarzt" + nil + "DTSTART;VALUE=DATE-TIME:20041102T150000 +DTEND;VALUE=DATE-TIME:20041102T163000 +SUMMARY:Zahnarzt") + + ;; 2005-02-07 lt + (icalendar-tests--test-import + "UID + :b60d398e-1dd1-11b2-a159-cf8cb05139f4 +SUMMARY + :Waitangi Day +DESCRIPTION + :abcdef +CATEGORIES + :Public Holiday +STATUS + :CONFIRMED +CLASS + :PRIVATE +DTSTART + ;VALUE=DATE + :20050206 +DTEND + ;VALUE=DATE + :20050207 +DTSTAMP + :20050128T011209Z" + nil + "&%%(and (diary-block 6 2 2005 6 2 2005)) Waitangi Day + Desc: abcdef + Status: CONFIRMED + Class: PRIVATE + UID: b60d398e-1dd1-11b2-a159-cf8cb05139f4 +" + "&%%(and (diary-block 2 6 2005 2 6 2005)) Waitangi Day + Desc: abcdef + Status: CONFIRMED + Class: PRIVATE + UID: b60d398e-1dd1-11b2-a159-cf8cb05139f4 +") + + ;; 2005-03-01 lt + (icalendar-tests--test-import + "DTSTART;VALUE=DATE:20050217 +SUMMARY:Hhhhhh Aaaaa ii Aaaaaaaa +UID:6AFA7558-6994-11D9-8A3A-000A95A0E830-RID +DTSTAMP:20050118T210335Z +DURATION:P7D" + nil + "&%%(and (diary-block 17 2 2005 23 2 2005)) Hhhhhh Aaaaa ii Aaaaaaaa + UID: 6AFA7558-6994-11D9-8A3A-000A95A0E830-RID\n" + "&%%(and (diary-block 2 17 2005 2 23 2005)) Hhhhhh Aaaaa ii Aaaaaaaa + UID: 6AFA7558-6994-11D9-8A3A-000A95A0E830-RID\n") + + ;; 2005-03-23 lt + (icalendar-tests--test-export + nil + "&%%(diary-cyclic 7 8 2 2005) 16:00-16:45 [WORK] Pppp" + nil + "DTSTART;VALUE=DATE-TIME:20050208T160000 +DTEND;VALUE=DATE-TIME:20050208T164500 +RRULE:FREQ=DAILY;INTERVAL=7 +SUMMARY:[WORK] Pppp +") + + ;; 2005-05-27 eu + (icalendar-tests--test-export + nil + nil + ;; FIXME: colon not allowed! + ;;"Nov 1: NNN Wwwwwwww Wwwww - Aaaaaa Pppppppp rrrrrr ddd oo Nnnnnnnn 30" + "Nov 1 NNN Wwwwwwww Wwwww - Aaaaaa Pppppppp rrrrrr ddd oo Nnnnnnnn 30" + "DTSTART;VALUE=DATE:19001101 +DTEND;VALUE=DATE:19001102 +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=11;BYMONTHDAY=1 +SUMMARY:NNN Wwwwwwww Wwwww - Aaaaaa Pppppppp rrrrrr ddd oo Nnnnnnnn 30 +") + + ;; bug#11473 + (icalendar-tests--test-import + "BEGIN:VCALENDAR +METHOD:REQUEST +PRODID:Microsoft Exchange Server 2007 +VERSION:2.0 +BEGIN:VTIMEZONE +TZID:(UTC+01:00) Amsterdam, Berlin, Bern, Rome, Stockholm, Vienna +BEGIN:STANDARD +DTSTART:16010101T030000 +TZOFFSETFROM:+0200 +TZOFFSETTO:+0100 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=-1SU;BYMONTH=10 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T020000 +TZOFFSETFROM:+0100 +TZOFFSETTO:+0200 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=-1SU;BYMONTH=3 +END:DAYLIGHT +END:VTIMEZONE +BEGIN:VEVENT +ORGANIZER;CN=\"A. Luser\":MAILTO:a.luser@foo.com +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN=\"Luser, Oth + er\":MAILTO:other.luser@foo.com +DESCRIPTION;LANGUAGE=en-US:\nWhassup?\n\n +SUMMARY;LANGUAGE=en-US:Query +DTSTART;TZID=\"(UTC+01:00) Amsterdam, Berlin, Bern, Rome, Stockholm, Vienna\" + :20120515T150000 +DTEND;TZID=\"(UTC+01:00) Amsterdam, Berlin, Bern, Rome, Stockholm, Vienna\":2 + 0120515T153000 +UID:040000008200E00074C5B7101A82E0080000000020FFAED0CFEFCC01000000000000000 + 010000000575268034ECDB649A15349B1BF240F15 +RECURRENCE-ID;TZID=\"(UTC+01:00) Amsterdam, Berlin, Bern, Rome, Stockholm, V + ienna\":20120515T170000 +CLASS:PUBLIC +PRIORITY:5 +DTSTAMP:20120514T153645Z +TRANSP:OPAQUE +STATUS:CONFIRMED +SEQUENCE:15 +LOCATION;LANGUAGE=en-US:phone +X-MICROSOFT-CDO-APPT-SEQUENCE:15 +X-MICROSOFT-CDO-OWNERAPPTID:1907632092 +X-MICROSOFT-CDO-BUSYSTATUS:TENTATIVE +X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY +X-MICROSOFT-CDO-ALLDAYEVENT:FALSE +X-MICROSOFT-CDO-IMPORTANCE:1 +X-MICROSOFT-CDO-INSTTYPE:3 +BEGIN:VALARM +ACTION:DISPLAY +DESCRIPTION:REMINDER +TRIGGER;RELATED=START:-PT15M +END:VALARM +END:VEVENT +END:VCALENDAR" + nil + "&15/5/2012 15:00-15:30 Query + Location: phone + Organizer: MAILTO:a.luser@foo.com + Status: CONFIRMED + Class: PUBLIC + UID: 040000008200E00074C5B7101A82E0080000000020FFAED0CFEFCC01000000000000000010000000575268034ECDB649A15349B1BF240F15 +" nil) + + ;; 2015-12-05, mixed line endings and empty lines, see Bug#22092. + (icalendar-tests--test-import + "BEGIN:VCALENDAR\r +PRODID:-//www.norwegian.no//iCalendar MIMEDIR//EN\r +VERSION:2.0\r +METHOD:REQUEST\r +BEGIN:VEVENT\r +UID:RFCALITEM1\r +SEQUENCE:1512040950\r +DTSTAMP:20141204T095043Z\r +ORGANIZER:noreply@norwegian.no\r +DTSTART:20141208T173000Z\r + +DTEND:20141208T215500Z\r + +LOCATION:Stavanger-Sola\r + +DESCRIPTION:Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390\r + +X-ALT-DESC;FMTTYPE=text/html:Reisereferanse

    +SUMMARY:Norwegian til Tromsoe-Langnes -\r + +CATEGORIES:Appointment\r + + +PRIORITY:5\r + +CLASS:PUBLIC\r + +TRANSP:OPAQUE\r +END:VEVENT\r +END:VCALENDAR +" +"&2014/12/8 18:30-22:55 Norwegian til Tromsoe-Langnes - + Desc: Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390 + Location: Stavanger-Sola + Organizer: noreply@norwegian.no + Class: PUBLIC + UID: RFCALITEM1 +" +"&8/12/2014 18:30-22:55 Norwegian til Tromsoe-Langnes - + Desc: Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390 + Location: Stavanger-Sola + Organizer: noreply@norwegian.no + Class: PUBLIC + UID: RFCALITEM1 +" +"&12/8/2014 18:30-22:55 Norwegian til Tromsoe-Langnes - + Desc: Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390 + Location: Stavanger-Sola + Organizer: noreply@norwegian.no + Class: PUBLIC + UID: RFCALITEM1 +" +) + ) + +(provide 'icalendar-tests) +;;; icalendar-tests.el ends here diff --cc test/lisp/char-fold-tests.el index 485254aa6cf,00000000000..d86c731b6e3 mode 100644,000000..100644 --- a/test/lisp/char-fold-tests.el +++ b/test/lisp/char-fold-tests.el @@@ -1,124 -1,0 +1,124 @@@ +;;; char-fold-tests.el --- Tests for char-fold.el -*- lexical-binding: t; -*- + - ;; Copyright (C) 2013-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + +;; Author: Artur Malabarba + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'ert) +(require 'char-fold) + +(defun char-fold--random-word (n) + (mapconcat (lambda (_) (string (+ 9 (random 117)))) + (make-list n nil) "")) + +(defun char-fold--test-search-with-contents (contents string) + (with-temp-buffer + (insert contents) + (goto-char (point-min)) + (should (search-forward-regexp (char-fold-to-regexp string) nil 'noerror)) + (goto-char (point-min)) + (should (char-fold-search-forward string nil 'noerror)) + (should (char-fold-search-backward string nil 'noerror)))) + + +(ert-deftest char-fold--test-consistency () + (dotimes (n 30) + (let ((w (char-fold--random-word n))) + ;; A folded string should always match the original string. + (char-fold--test-search-with-contents w w)))) + +(ert-deftest char-fold--test-lax-whitespace () + (dotimes (n 40) + (let ((w1 (char-fold--random-word n)) + (w2 (char-fold--random-word n)) + (search-spaces-regexp "\\s-+")) + (char-fold--test-search-with-contents + (concat w1 "\s\n\s\t\f\t\n\r\t" w2) + (concat w1 " " w2)) + (char-fold--test-search-with-contents + (concat w1 "\s\n\s\t\f\t\n\r\t" w2) + (concat w1 (make-string 10 ?\s) w2))))) + +(defun char-fold--test-match-exactly (string &rest strings-to-match) + (let ((re (concat "\\`" (char-fold-to-regexp string) "\\'"))) + (dolist (it strings-to-match) + (should (string-match re it))) + ;; Case folding + (let ((case-fold-search t)) + (dolist (it strings-to-match) + (should (string-match (upcase re) (downcase it))) + (should (string-match (downcase re) (upcase it))))))) + +(ert-deftest char-fold--test-some-defaults () + (dolist (it '(("ffl" . "ffl") ("ffi" . "ffi") + ("fi" . "fi") ("ff" . "ff") + ("ä" . "ä"))) + (char-fold--test-search-with-contents (cdr it) (car it)) + (let ((multi (char-table-extra-slot char-fold-table 0)) + (char-fold-table (make-char-table 'char-fold-table))) + (set-char-table-extra-slot char-fold-table 0 multi) + (char-fold--test-match-exactly (car it) (cdr it))))) + +(ert-deftest char-fold--test-fold-to-regexp () + (let ((char-fold-table (make-char-table 'char-fold-table)) + (multi (make-char-table 'char-fold-table))) + (set-char-table-extra-slot char-fold-table 0 multi) + (aset char-fold-table ?a "xx") + (aset char-fold-table ?1 "44") + (aset char-fold-table ?\s "-!-") + (char-fold--test-match-exactly "a1a1" "xx44xx44") + (char-fold--test-match-exactly "a1 a 1" "xx44-!--!-xx-!-44") + (aset multi ?a '(("1" . "99") + ("2" . "88") + ("12" . "77"))) + (char-fold--test-match-exactly "a" "xx") + (char-fold--test-match-exactly "a1" "xx44" "99") + (char-fold--test-match-exactly "a12" "77" "xx442" "992") + (char-fold--test-match-exactly "a2" "88") + (aset multi ?1 '(("2" . "yy"))) + (char-fold--test-match-exactly "a1" "xx44" "99") + (char-fold--test-match-exactly "a12" "77" "xx442" "992") + ;; Support for this case is disabled. See function definition or: + ;; https://lists.gnu.org/archive/html/emacs-devel/2015-11/msg02562.html + ;; (char-fold--test-match-exactly "a12" "xxyy") + )) + +(ert-deftest char-fold--speed-test () + (dolist (string (append '("tty-set-up-initial-frame-face" + "tty-set-up-initial-frame-face-frame-faceframe-faceframe-faceframe-face") + (mapcar #'char-fold--random-word '(10 50 100 + 50 100)))) + (message "Testing %s" string) + ;; Make sure we didn't just fallback on the trivial search. + (should-not (string= (regexp-quote string) + (char-fold-to-regexp string))) + (with-temp-buffer + (save-excursion (insert string)) + (let ((time (time-to-seconds (current-time)))) + ;; Our initial implementation of case-folding in char-folding + ;; created a lot of redundant paths in the regexp. Because of + ;; that, if a really long string "almost" matches, the regexp + ;; engine took a long time to realize that it doesn't match. + (should-not (char-fold-search-forward (concat string "c") nil 'noerror)) + ;; Ensure it took less than a second. + (should (< (- (time-to-seconds (current-time)) + time) + 1)))))) + +(provide 'char-fold-tests) +;;; char-fold-tests.el ends here diff --cc test/lisp/comint-tests.el index 576be238408,00000000000..3205c9e4cd3 mode 100644,000000..100644 --- a/test/lisp/comint-tests.el +++ b/test/lisp/comint-tests.el @@@ -1,54 -1,0 +1,54 @@@ +;;; comint-testsuite.el + - ;; Copyright (C) 2010-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2010-2017 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Tests for comint and related modes. + +;;; Code: + +(require 'comint) +(require 'ert) + +(defvar comint-testsuite-password-strings + '("foo@example.net's password: " ; ssh + "Password for foo@example.org: " ; kinit + "Please enter the password for foo@example.org: " ; kinit + "Kerberos password for devnull/root GNU.ORG: " ; ksu + "Enter passphrase: " ; ssh-add + "Enter passphrase (empty for no passphrase): " ; ssh-keygen + "Enter same passphrase again: " ; ssh-keygen + "Passphrase for key root@GNU.ORG: " ; plink + "[sudo] password for user:" ; Ubuntu sudo + "Password (again):" + "Enter password:" + "Mot de Passe:" ; localized + "Passwort:") ; localized + "List of strings that should match `comint-password-prompt-regexp'.") + +(ert-deftest comint-test-password-regexp () + "Test `comint-password-prompt-regexp' against common password strings." + (dolist (str comint-testsuite-password-strings) + (should (string-match comint-password-prompt-regexp str)))) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +;;; comint-testsuite.el ends here diff --cc test/lisp/dabbrev-tests.el index 9c7a8385535,00000000000..5baa31558e7 mode 100644,000000..100644 --- a/test/lisp/dabbrev-tests.el +++ b/test/lisp/dabbrev-tests.el @@@ -1,42 -1,0 +1,42 @@@ +;;; dabbrev-tests.el --- Test suite for dabbrev. + - ;; Copyright (C) 2016 Free Software Foundation, Inc. ++;; Copyright (C) 2016-2017 Free Software Foundation, Inc. + +;; Author: Alan Third +;; Keywords: dabbrev + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'dabbrev) + +(ert-deftest dabbrev-expand-test () + "Test for bug#1948. +When DABBREV-ELIMINATE-NEWLINES is non-nil (the default), +repeated calls to DABBREV-EXPAND can result in the source of +first expansion being replaced rather than the destination." + (with-temp-buffer + (insert "ab x\na\nab y") + (goto-char 8) + (save-window-excursion + (set-window-buffer nil (current-buffer)) + ;; M-/ SPC M-/ M-/ + (execute-kbd-macro "\257 \257\257")) + (should (string= (buffer-string) "ab x\nab y\nab y")))) diff --cc test/lisp/descr-text-tests.el index 9e851c3a119,00000000000..df0f8453161 mode 100644,000000..100644 --- a/test/lisp/descr-text-tests.el +++ b/test/lisp/descr-text-tests.el @@@ -1,94 -1,0 +1,94 @@@ +;;; descr-text-test.el --- ERT tests for descr-text.el -*- lexical-binding: t -*- + - ;; Copyright (C) 2014, 2016 Free Software Foundation, Inc. ++;; Copyright (C) 2014, 2016-2017 Free Software Foundation, Inc. + +;; Author: Michal Nazarewicz + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This package defines regression tests for the descr-text package. + +;;; Code: + +(require 'ert) +(require 'descr-text) + + +(ert-deftest descr-text-test-truncate () + "Tests describe-char-eldoc--truncate function." + (should (equal "" + (describe-char-eldoc--truncate " \t \n" 100))) + (should (equal "foo" + (describe-char-eldoc--truncate "foo" 1))) + (should (equal "foo..." + (describe-char-eldoc--truncate "foo wilma fred" 0))) + (should (equal "foo..." + (describe-char-eldoc--truncate + "foo wilma fred" (length "foo wilma")))) + (should (equal "foo wilma..." + (describe-char-eldoc--truncate + "foo wilma fred" (+ 3 (length "foo wilma"))))) + (should (equal "foo wilma..." + (describe-char-eldoc--truncate + "foo wilma fred" (1- (length "foo wilma fred"))))) + (should (equal "foo wilma fred" + (describe-char-eldoc--truncate + "foo wilma fred" (length "foo wilma fred")))) + (should (equal "foo wilma fred" + (describe-char-eldoc--truncate + " foo\t wilma \nfred\t " (length "foo wilma fred"))))) + +(ert-deftest descr-text-test-format-desc () + "Tests describe-char-eldoc--format function." + (should (equal "U+2026: Horizontal ellipsis (Po: Punctuation, Other)" + (describe-char-eldoc--format ?…))) + (should (equal "U+2026: Horizontal ellipsis (Punctuation, Other)" + (describe-char-eldoc--format ?… 51))) + (should (equal "U+2026: Horizontal ellipsis (Po)" + (describe-char-eldoc--format ?… 40))) + (should (equal "Horizontal ellipsis (Po)" + (describe-char-eldoc--format ?… 30))) + (should (equal "Horizontal ellipsis" + (describe-char-eldoc--format ?… 20))) + (should (equal "Horizontal..." + (describe-char-eldoc--format ?… 10)))) + +(ert-deftest descr-text-test-desc () + "Tests describe-char-eldoc function." + (with-temp-buffer + (insert "a…") + (goto-char (point-min)) + (should (eq ?a (following-char))) ; make sure we are where we think we are + ;; Function should return nil for an ASCII character. + (should (not (describe-char-eldoc))) + + (goto-char (1+ (point))) + (should (eq ?… (following-char))) + (let ((eldoc-echo-area-use-multiline-p t)) + ;; Function should return description of an Unicode character. + (should (equal "U+2026: Horizontal ellipsis (Po: Punctuation, Other)" + (describe-char-eldoc)))) + + (goto-char (point-max)) + ;; At the end of the buffer, function should return nil and not blow up. + (should (not (describe-char-eldoc))))) + + +(provide 'descr-text-test) + +;;; descr-text-test.el ends here diff --cc test/lisp/electric-tests.el index 17b4e024ab2,00000000000..78a37650619 mode 100644,000000..100644 --- a/test/lisp/electric-tests.el +++ b/test/lisp/electric-tests.el @@@ -1,597 -1,0 +1,597 @@@ +;;; electric-tests.el --- tests for electric.el + - ;; Copyright (C) 2013-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + +;; Author: João Távora +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Tests for Electric Pair mode. +;; TODO: Add tests for other Electric-* functionality + +;;; Code: +(require 'ert) +(require 'ert-x) +(require 'electric) +(require 'elec-pair) +(require 'cl-lib) + +(defun call-with-saved-electric-modes (fn) + (let ((saved-electric (if electric-pair-mode 1 -1)) + (saved-layout (if electric-layout-mode 1 -1)) + (saved-indent (if electric-indent-mode 1 -1))) + (electric-pair-mode -1) + (electric-layout-mode -1) + (electric-indent-mode -1) + (unwind-protect + (funcall fn) + (electric-pair-mode saved-electric) + (electric-indent-mode saved-indent) + (electric-layout-mode saved-layout)))) + +(defmacro save-electric-modes (&rest body) + (declare (indent defun) (debug t)) + `(call-with-saved-electric-modes #'(lambda () ,@body))) + +(defun electric-pair-test-for (fixture where char expected-string + expected-point mode bindings fixture-fn) + (with-temp-buffer + (funcall mode) + (insert fixture) + (save-electric-modes + (let ((last-command-event char) + (transient-mark-mode 'lambda)) + (goto-char where) + (funcall fixture-fn) + (cl-progv + (mapcar #'car bindings) + (mapcar #'cdr bindings) + (call-interactively (key-binding `[,last-command-event]))))) + (should (equal (buffer-substring-no-properties (point-min) (point-max)) + expected-string)) + (should (equal (point) + expected-point)))) + +(eval-when-compile + (defun electric-pair-define-test-form (name fixture + char + pos + expected-string + expected-point + skip-pair-string + prefix + suffix + extra-desc + mode + bindings + fixture-fn) + (let* ((expected-string-and-point + (if skip-pair-string + (with-temp-buffer + (cl-progv + ;; FIXME: avoid `eval' + (mapcar #'car (eval bindings)) + (mapcar #'cdr (eval bindings)) + (funcall mode) + (insert fixture) + (goto-char (1+ pos)) + (insert char) + (cond ((eq (aref skip-pair-string pos) + ?p) + (insert (cadr (electric-pair-syntax-info char))) + (backward-char 1)) + ((eq (aref skip-pair-string pos) + ?s) + (delete-char -1) + (forward-char 1))) + (list + (buffer-substring-no-properties (point-min) (point-max)) + (point)))) + (list expected-string expected-point))) + (expected-string (car expected-string-and-point)) + (expected-point (cadr expected-string-and-point)) + (fixture (format "%s%s%s" prefix fixture suffix)) + (expected-string (format "%s%s%s" prefix expected-string suffix)) + (expected-point (+ (length prefix) expected-point)) + (pos (+ (length prefix) pos))) + `(ert-deftest ,(intern (format "electric-pair-%s-at-point-%s-in-%s%s" + name + (1+ pos) + mode + extra-desc)) + () + ,(format "With |%s|, try input %c at point %d. \ +Should %s |%s| and point at %d" + fixture + char + (1+ pos) + (if (string= fixture expected-string) + "stay" + "become") + (replace-regexp-in-string "\n" "\\\\n" expected-string) + expected-point) + (electric-pair-test-for ,fixture + ,(1+ pos) + ,char + ,expected-string + ,expected-point + ',mode + ,bindings + ,fixture-fn))))) + +(cl-defmacro define-electric-pair-test + (name fixture + input + &key + skip-pair-string + expected-string + expected-point + bindings + (modes '(quote (ruby-mode c++-mode))) + (test-in-comments t) + (test-in-strings t) + (test-in-code t) + (fixture-fn #'(lambda () + (electric-pair-mode 1)))) + `(progn + ,@(cl-loop + for mode in (eval modes) ;FIXME: avoid `eval' + append + (cl-loop + for (prefix suffix extra-desc) in + (append (if test-in-comments + `((,(with-temp-buffer + (funcall mode) + (insert "z") + (comment-region (point-min) (point-max)) + (buffer-substring-no-properties (point-min) + (1- (point-max)))) + "" + "-in-comments"))) + (if test-in-strings + `(("\"" "\"" "-in-strings"))) + (if test-in-code + `(("" "" "")))) + append + (cl-loop + for char across input + for pos from 0 + unless (eq char ?-) + collect (electric-pair-define-test-form + name + fixture + (aref input pos) + pos + expected-string + expected-point + skip-pair-string + prefix + suffix + extra-desc + mode + bindings + fixture-fn)))))) + +;;; Basic pairs and skips +;;; +(define-electric-pair-test balanced-situation + " (()) " "(((((((" :skip-pair-string "ppppppp" + :modes '(ruby-mode)) + +(define-electric-pair-test too-many-openings + " ((()) " "(((((((" :skip-pair-string "ppppppp") + +(define-electric-pair-test too-many-closings + " (())) " "(((((((" :skip-pair-string "------p") + +(define-electric-pair-test too-many-closings-2 + "() ) " "---(---" :skip-pair-string "-------") + +(define-electric-pair-test too-many-closings-3 + ")() " "(------" :skip-pair-string "-------") + +(define-electric-pair-test balanced-autoskipping + " (()) " "---))--" :skip-pair-string "---ss--") + +(define-electric-pair-test too-many-openings-autoskipping + " ((()) " "----))-" :skip-pair-string "-------") + +(define-electric-pair-test too-many-closings-autoskipping + " (())) " "---)))-" :skip-pair-string "---sss-") + + +;;; Mixed parens +;;; +(define-electric-pair-test mixed-paren-1 + " ()] " "-(-(---" :skip-pair-string "-p-p---") + +(define-electric-pair-test mixed-paren-2 + " [() " "-(-()--" :skip-pair-string "-p-ps--") + +(define-electric-pair-test mixed-paren-3 + " (]) " "-(-()--" :skip-pair-string "---ps--") + +(define-electric-pair-test mixed-paren-4 + " ()] " "---)]--" :skip-pair-string "---ss--") + +(define-electric-pair-test mixed-paren-5 + " [() " "----(--" :skip-pair-string "----p--") + +(define-electric-pair-test find-matching-different-paren-type + " ()] " "-[-----" :skip-pair-string "-------") + +(define-electric-pair-test find-matching-different-paren-type-inside-list + "( ()]) " "-[-----" :skip-pair-string "-------") + +(define-electric-pair-test ignore-different-nonmatching-paren-type + "( ()]) " "-(-----" :skip-pair-string "-p-----") + +(define-electric-pair-test autopair-keep-least-amount-of-mixed-unbalance + "( ()] " "-(-----" :skip-pair-string "-p-----") + +(define-electric-pair-test dont-autopair-to-resolve-mixed-unbalance + "( ()] " "-[-----" :skip-pair-string "-------") + +(define-electric-pair-test autopair-so-as-not-to-worsen-unbalance-situation + "( (]) " "-[-----" :skip-pair-string "-p-----") + +(define-electric-pair-test skip-over-partially-balanced + " [([]) " "-----)---" :skip-pair-string "-----s---") + +(define-electric-pair-test only-skip-over-at-least-partially-balanced-stuff + " [([()) " "-----))--" :skip-pair-string "-----s---") + + + + +;;; Quotes +;;; +(define-electric-pair-test pair-some-quotes-skip-others + " \"\" " "-\"\"-----" :skip-pair-string "-ps------" + :test-in-strings nil + :bindings `((electric-pair-text-syntax-table + . ,prog-mode-syntax-table))) + +(define-electric-pair-test skip-single-quotes-in-ruby-mode + " '' " "--'-" :skip-pair-string "--s-" + :modes '(ruby-mode) + :test-in-comments nil + :test-in-strings nil + :bindings `((electric-pair-text-syntax-table + . ,prog-mode-syntax-table))) + +(define-electric-pair-test leave-unbalanced-quotes-alone + " \"' " "-\"'-" :skip-pair-string "----" + :modes '(ruby-mode) + :test-in-strings nil + :bindings `((electric-pair-text-syntax-table + . ,prog-mode-syntax-table))) + +(define-electric-pair-test leave-unbalanced-quotes-alone-2 + " \"\\\"' " "-\"--'-" :skip-pair-string "------" + :modes '(ruby-mode) + :test-in-strings nil + :bindings `((electric-pair-text-syntax-table + . ,prog-mode-syntax-table))) + +(define-electric-pair-test leave-unbalanced-quotes-alone-3 + " foo\\''" "'------" :skip-pair-string "-------" + :modes '(ruby-mode) + :test-in-strings nil + :bindings `((electric-pair-text-syntax-table + . ,prog-mode-syntax-table))) + +(define-electric-pair-test inhibit-if-strings-mismatched + "\"foo\"\"bar" "\"" + :expected-string "\"\"foo\"\"bar" + :expected-point 2 + :test-in-strings nil + :bindings `((electric-pair-text-syntax-table + . ,prog-mode-syntax-table))) + +(define-electric-pair-test inhibit-in-mismatched-string-inside-ruby-comments + "foo\"\" +# +# \"bar\" +# \" \" +# \" +# +baz\"\"" + "\"" + :modes '(ruby-mode) + :test-in-strings nil + :test-in-comments nil + :expected-point 19 + :expected-string + "foo\"\" +# +# \"bar\"\" +# \" \" +# \" +# +baz\"\"" + :fixture-fn #'(lambda () (goto-char (point-min)) (search-forward "bar"))) + +(define-electric-pair-test inhibit-in-mismatched-string-inside-c-comments + "foo\"\"/* + \"bar\" + \" \" + \" +*/baz\"\"" + "\"" + :modes '(c-mode) + :test-in-strings nil + :test-in-comments nil + :expected-point 18 + :expected-string + "foo\"\"/* + \"bar\"\" + \" \" + \" +*/baz\"\"" + :fixture-fn #'(lambda () (goto-char (point-min)) (search-forward "bar"))) + + +;;; More quotes, but now don't bind `electric-pair-text-syntax-table' +;;; to `prog-mode-syntax-table'. Use the defaults for +;;; `electric-pair-pairs' and `electric-pair-text-pairs'. +;;; +(define-electric-pair-test pairing-skipping-quotes-in-code + " \"\" " "-\"\"-----" :skip-pair-string "-ps------" + :test-in-strings nil + :test-in-comments nil) + +(define-electric-pair-test skipping-quotes-in-comments + " \"\" " "--\"-----" :skip-pair-string "--s------" + :test-in-strings nil) + + +;;; Skipping over whitespace +;;; +(define-electric-pair-test whitespace-jumping + " ( ) " "--))))---" :expected-string " ( ) " :expected-point 8 + :bindings '((electric-pair-skip-whitespace . t))) + +(define-electric-pair-test whitespace-chomping + " ( ) " "--)------" :expected-string " () " :expected-point 4 + :bindings '((electric-pair-skip-whitespace . chomp))) + +(define-electric-pair-test whitespace-chomping-2 + " ( \n\t\t\n ) " "--)------" :expected-string " () " :expected-point 4 + :bindings '((electric-pair-skip-whitespace . chomp)) + :test-in-comments nil) + +(define-electric-pair-test whitespace-chomping-dont-cross-comments + " ( \n\t\t\n ) " "--)------" :expected-string " () \n\t\t\n ) " + :expected-point 4 + :bindings '((electric-pair-skip-whitespace . chomp)) + :test-in-strings nil + :test-in-code nil + :test-in-comments t) + +(define-electric-pair-test whitespace-skipping-for-quotes-not-outside + " \" \"" "\"-----" :expected-string "\"\" \" \"" + :expected-point 2 + :bindings '((electric-pair-skip-whitespace . chomp)) + :test-in-strings nil + :test-in-code t + :test-in-comments nil) + +(define-electric-pair-test whitespace-skipping-for-quotes-only-inside + " \" \"" "---\"--" :expected-string " \"\"" + :expected-point 5 + :bindings '((electric-pair-skip-whitespace . chomp)) + :test-in-strings nil + :test-in-code t + :test-in-comments nil) + +(define-electric-pair-test whitespace-skipping-quotes-not-without-proper-syntax + " \" \"" "---\"--" :expected-string " \"\"\" \"" + :expected-point 5 + :modes '(text-mode) + :bindings '((electric-pair-skip-whitespace . chomp)) + :test-in-strings nil + :test-in-code t + :test-in-comments nil) + + +;;; Pairing arbitrary characters +;;; +(define-electric-pair-test angle-brackets-everywhere + "<>" "<>" :skip-pair-string "ps" + :bindings '((electric-pair-pairs . ((?\< . ?\>))))) + +(define-electric-pair-test angle-brackets-everywhere-2 + "(<>" "-<>" :skip-pair-string "-ps" + :bindings '((electric-pair-pairs . ((?\< . ?\>))))) + +(defvar electric-pair-test-angle-brackets-table + (let ((table (make-syntax-table prog-mode-syntax-table))) + (modify-syntax-entry ?\< "(>" table) + (modify-syntax-entry ?\> ")<`" table) + table)) + +(define-electric-pair-test angle-brackets-pair + "<>" "<" :expected-string "<><>" :expected-point 2 + :test-in-code nil + :bindings `((electric-pair-text-syntax-table + . ,electric-pair-test-angle-brackets-table))) + +(define-electric-pair-test angle-brackets-skip + "<>" "->" :expected-string "<>" :expected-point 3 + :test-in-code nil + :bindings `((electric-pair-text-syntax-table + . ,electric-pair-test-angle-brackets-table))) + +(define-electric-pair-test pair-backtick-and-quote-in-comments + ";; " "---`" :expected-string ";; `'" :expected-point 5 + :test-in-comments nil + :test-in-strings nil + :modes '(emacs-lisp-mode) + :bindings '((electric-pair-text-pairs . ((?\` . ?\'))))) + +(define-electric-pair-test skip-backtick-and-quote-in-comments + ";; `foo'" "-------'" :expected-string ";; `foo'" :expected-point 9 + :test-in-comments nil + :test-in-strings nil + :modes '(emacs-lisp-mode) + :bindings '((electric-pair-text-pairs . ((?\` . ?\'))))) + +(define-electric-pair-test pair-backtick-and-quote-in-strings + "\"\"" "-`" :expected-string "\"`'\"" :expected-point 3 + :test-in-comments nil + :test-in-strings nil + :modes '(emacs-lisp-mode) + :bindings '((electric-pair-text-pairs . ((?\` . ?\'))))) + +(define-electric-pair-test skip-backtick-and-quote-in-strings + "\"`'\"" "--'" :expected-string "\"`'\"" :expected-point 4 + :test-in-comments nil + :test-in-strings nil + :modes '(emacs-lisp-mode) + :bindings '((electric-pair-text-pairs . ((?\` . ?\'))))) + +(define-electric-pair-test skip-backtick-and-quote-in-strings-2 + " \"`'\"" "----'" :expected-string " \"`'\"" :expected-point 6 + :test-in-comments nil + :test-in-strings nil + :modes '(emacs-lisp-mode) + :bindings '((electric-pair-text-pairs . ((?\` . ?\'))))) + + +;;; `js-mode' has `electric-layout-rules' for '{ and '} +;;; +(define-electric-pair-test js-mode-braces + "" "{" :expected-string "{}" :expected-point 2 + :modes '(js-mode) + :fixture-fn #'(lambda () + (electric-pair-mode 1))) + +(define-electric-pair-test js-mode-braces-with-layout + "" "{" :expected-string "{\n\n}" :expected-point 3 + :modes '(js-mode) + :test-in-comments nil + :test-in-strings nil + :fixture-fn #'(lambda () + (electric-layout-mode 1) + (electric-pair-mode 1))) + +(define-electric-pair-test js-mode-braces-with-layout-and-indent + "" "{" :expected-string "{\n \n}" :expected-point 7 + :modes '(js-mode) + :test-in-comments nil + :test-in-strings nil + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (electric-indent-mode 1) + (electric-layout-mode 1))) + + +;;; Backspacing +;;; TODO: better tests +;;; +(ert-deftest electric-pair-backspace-1 () + (save-electric-modes + (with-temp-buffer + (insert "()") + (goto-char 2) + (electric-pair-delete-pair 1) + (should (equal "" (buffer-string)))))) + + +;;; Electric newlines between pairs +;;; TODO: better tests +(ert-deftest electric-pair-open-extra-newline () + (save-electric-modes + (with-temp-buffer + (c-mode) + (electric-pair-mode 1) + (electric-indent-mode 1) + (insert "int main {}") + (backward-char 1) + (let ((c-basic-offset 4)) + (newline 1 t) + (should (equal "int main {\n \n}" + (buffer-string))) + (should (equal (point) (- (point-max) 2))))))) + + + +;;; Autowrapping +;;; +(define-electric-pair-test autowrapping-1 + "foo" "(" :expected-string "(foo)" :expected-point 2 + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (mark-sexp 1))) + +(define-electric-pair-test autowrapping-2 + "foo" ")" :expected-string "(foo)" :expected-point 6 + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (mark-sexp 1))) + +(define-electric-pair-test autowrapping-3 + "foo" ")" :expected-string "(foo)" :expected-point 6 + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (goto-char (point-max)) + (skip-chars-backward "\"") + (mark-sexp -1))) + +(define-electric-pair-test autowrapping-4 + "foo" "(" :expected-string "(foo)" :expected-point 2 + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (goto-char (point-max)) + (skip-chars-backward "\"") + (mark-sexp -1))) + +(define-electric-pair-test autowrapping-5 + "foo" "\"" :expected-string "\"foo\"" :expected-point 2 + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (mark-sexp 1))) + +(define-electric-pair-test autowrapping-6 + "foo" "\"" :expected-string "\"foo\"" :expected-point 6 + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (goto-char (point-max)) + (skip-chars-backward "\"") + (mark-sexp -1))) + +(define-electric-pair-test autowrapping-7 + "foo" "\"" :expected-string "``foo''" :expected-point 8 + :modes '(tex-mode) + :test-in-comments nil + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (goto-char (point-max)) + (skip-chars-backward "\"") + (mark-sexp -1))) + + +;;; Electric quotes +(define-electric-pair-test electric-quote-string + "" "'" :expected-string "'" :expected-point 2 + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-string . t)) + :test-in-comments nil :test-in-strings nil) + +(provide 'electric-tests) +;;; electric-tests.el ends here diff --cc test/lisp/emacs-lisp/bytecomp-tests.el index 91d438eae0f,00000000000..bc47c82c1e1 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@@ -1,470 -1,0 +1,470 @@@ +;;; bytecomp-tests.el + - ;; Copyright (C) 2008-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2008-2017 Free Software Foundation, Inc. + +;; Author: Shigeru Fukaya +;; Author: Stefan Monnier +;; Created: November 2008 +;; Keywords: internal +;; Human-Keywords: internal + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +(require 'ert) + +;;; Code: +(defconst byte-opt-testsuite-arith-data + '( + ;; some functional tests + (let ((a most-positive-fixnum) (b 1) (c 1.0)) (+ a b c)) + (let ((a most-positive-fixnum) (b -2) (c 1.0)) (- a b c)) + (let ((a most-positive-fixnum) (b 2) (c 1.0)) (* a b c)) + (let ((a 3) (b 2) (c 1.0)) (/ a b c)) + (let ((a (+ 1 (expt 2 -64))) (b (expt 2 -65))) (+ a -1 b)) + (let ((a (+ 1 (expt 2 -64))) (b (expt 2 -65))) (- a 1 (- b))) + ;; This fails. Should it be a bug? + ;; (let ((a (expt 2 -1074)) (b 0.125)) (* a 8 b)) + (let ((a 1.0)) (* a 0)) + (let ((a 1.0)) (* a 2.0 0)) + (let ((a 1.0)) (/ 0 a)) + (let ((a 1.0)) (/ 3 a 2)) + (let ((a most-positive-fixnum) (b 2.0)) (* a 2 b)) + (let ((a 3) (b 2)) (/ a b 1.0)) + (/ 3 -1) + (+ 4 3 2 1) + (+ 4 3 2.0 1) + (- 4 3 2 1) ; not new, for reference + (- 4 3 2.0 1) ; not new, for reference + (* 4 3 2 1) + (* 4 3 2.0 1) + (/ 4 3 2 1) + (/ 4 3 2.0 1) + (let ((a 3) (b 2)) (+ a b 1)) + (let ((a 3) (b 2)) (+ a b -1)) + (let ((a 3) (b 2)) (- a b 1)) + (let ((a 3) (b 2)) (- a b -1)) + (let ((a 3) (b 2)) (+ a b a 1)) + (let ((a 3) (b 2)) (+ a b a -1)) + (let ((a 3) (b 2)) (- a b a 1)) + (let ((a 3) (b 2)) (- a b a -1)) + (let ((a 3) (b 2)) (* a b -1)) + (let ((a 3) (b 2)) (* a -1)) + (let ((a 3) (b 2)) (/ a b 1)) + (let ((a 3) (b 2)) (/ (+ a b) 1)) + + ;; coverage test + (let ((a 3) (b 2) (c 1.0)) (+)) + (let ((a 3) (b 2) (c 1.0)) (+ 2)) + (let ((a 3) (b 2) (c 1.0)) (+ 2 0)) + (let ((a 3) (b 2) (c 1.0)) (+ 2 0.0)) + (let ((a 3) (b 2) (c 1.0)) (+ 2.0)) + (let ((a 3) (b 2) (c 1.0)) (+ 2.0 0)) + (let ((a 3) (b 2) (c 1.0)) (+ 2.0 0.0)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 2)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (+ 0.0 2)) + (let ((a 3) (b 2) (c 1.0)) (+ 0.0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (+ a)) + (let ((a 3) (b 2) (c 1.0)) (+ a 0)) + (let ((a 3) (b 2) (c 1.0)) (+ a 0.0)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 a)) + (let ((a 3) (b 2) (c 1.0)) (+ 0.0 a)) + (let ((a 3) (b 2) (c 1.0)) (+ c 0)) + (let ((a 3) (b 2) (c 1.0)) (+ c 0.0)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 c)) + (let ((a 3) (b 2) (c 1.0)) (+ 0.0 c)) + (let ((a 3) (b 2) (c 1.0)) (+ a b 0 c 0)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 a)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 a b)) + (let ((a 3) (b 2) (c 1.0)) (+ 0 a b c)) + (let ((a 3) (b 2) (c 1.0)) (+ 1 2 3)) + (let ((a 3) (b 2) (c 1.0)) (+ 3.0 2.0 1)) + (let ((a 3) (b 2) (c 1.0)) (+ 3.0 2.0 1 4)) + (let ((a 3) (b 2) (c 1.0)) (+ a 1)) + (let ((a 3) (b 2) (c 1.0)) (+ a -1)) + (let ((a 3) (b 2) (c 1.0)) (+ 1 a)) + (let ((a 3) (b 2) (c 1.0)) (+ -1 a)) + (let ((a 3) (b 2) (c 1.0)) (+ c 1)) + (let ((a 3) (b 2) (c 1.0)) (+ c -1)) + (let ((a 3) (b 2) (c 1.0)) (+ 1 c)) + (let ((a 3) (b 2) (c 1.0)) (+ -1 c)) + (let ((a 3) (b 2) (c 1.0)) (+ a b 0)) + (let ((a 3) (b 2) (c 1.0)) (+ a b 1)) + (let ((a 3) (b 2) (c 1.0)) (+ a b -1)) + (let ((a 3) (b 2) (c 1.0)) (+ a b 2)) + (let ((a 3) (b 2) (c 1.0)) (+ 1 a b c)) + (let ((a 3) (b 2) (c 1.0)) (+ a b c 0)) + (let ((a 3) (b 2) (c 1.0)) (+ a b c 1)) + (let ((a 3) (b 2) (c 1.0)) (+ a b c -1)) + + (let ((a 3) (b 2) (c 1.0)) (-)) + (let ((a 3) (b 2) (c 1.0)) (- 2)) + (let ((a 3) (b 2) (c 1.0)) (- 2 0)) + (let ((a 3) (b 2) (c 1.0)) (- 2 0.0)) + (let ((a 3) (b 2) (c 1.0)) (- 2.0)) + (let ((a 3) (b 2) (c 1.0)) (- 2.0 0)) + (let ((a 3) (b 2) (c 1.0)) (- 2.0 0.0)) + (let ((a 3) (b 2) (c 1.0)) (- 0 2)) + (let ((a 3) (b 2) (c 1.0)) (- 0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (- 0.0 2)) + (let ((a 3) (b 2) (c 1.0)) (- 0.0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (- a)) + (let ((a 3) (b 2) (c 1.0)) (- a 0)) + (let ((a 3) (b 2) (c 1.0)) (- a 0.0)) + (let ((a 3) (b 2) (c 1.0)) (- 0 a)) + (let ((a 3) (b 2) (c 1.0)) (- 0.0 a)) + (let ((a 3) (b 2) (c 1.0)) (- c 0)) + (let ((a 3) (b 2) (c 1.0)) (- c 0.0)) + (let ((a 3) (b 2) (c 1.0)) (- 0 c)) + (let ((a 3) (b 2) (c 1.0)) (- 0.0 c)) + (let ((a 3) (b 2) (c 1.0)) (- a b 0 c 0)) + (let ((a 3) (b 2) (c 1.0)) (- 0 a)) + (let ((a 3) (b 2) (c 1.0)) (- 0 a b)) + (let ((a 3) (b 2) (c 1.0)) (- 0 a b c)) + (let ((a 3) (b 2) (c 1.0)) (- 1 2 3)) + (let ((a 3) (b 2) (c 1.0)) (- 3.0 2.0 1)) + (let ((a 3) (b 2) (c 1.0)) (- 3.0 2.0 1 4)) + (let ((a 3) (b 2) (c 1.0)) (- a 1)) + (let ((a 3) (b 2) (c 1.0)) (- a -1)) + (let ((a 3) (b 2) (c 1.0)) (- 1 a)) + (let ((a 3) (b 2) (c 1.0)) (- -1 a)) + (let ((a 3) (b 2) (c 1.0)) (- c 1)) + (let ((a 3) (b 2) (c 1.0)) (- c -1)) + (let ((a 3) (b 2) (c 1.0)) (- 1 c)) + (let ((a 3) (b 2) (c 1.0)) (- -1 c)) + (let ((a 3) (b 2) (c 1.0)) (- a b 0)) + (let ((a 3) (b 2) (c 1.0)) (- a b 1)) + (let ((a 3) (b 2) (c 1.0)) (- a b -1)) + (let ((a 3) (b 2) (c 1.0)) (- a b 2)) + (let ((a 3) (b 2) (c 1.0)) (- 1 a b c)) + (let ((a 3) (b 2) (c 1.0)) (- a b c 0)) + (let ((a 3) (b 2) (c 1.0)) (- a b c 1)) + (let ((a 3) (b 2) (c 1.0)) (- a b c -1)) + + (let ((a 3) (b 2) (c 1.0)) (*)) + (let ((a 3) (b 2) (c 1.0)) (* 2)) + (let ((a 3) (b 2) (c 1.0)) (* 2 0)) + (let ((a 3) (b 2) (c 1.0)) (* 2 0.0)) + (let ((a 3) (b 2) (c 1.0)) (* 2.0)) + (let ((a 3) (b 2) (c 1.0)) (* 2.0 0)) + (let ((a 3) (b 2) (c 1.0)) (* 2.0 0.0)) + (let ((a 3) (b 2) (c 1.0)) (* 0 2)) + (let ((a 3) (b 2) (c 1.0)) (* 0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (* 0.0 2)) + (let ((a 3) (b 2) (c 1.0)) (* 0.0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (* a)) + (let ((a 3) (b 2) (c 1.0)) (* a 0)) + (let ((a 3) (b 2) (c 1.0)) (* a 0.0)) + (let ((a 3) (b 2) (c 1.0)) (* 0 a)) + (let ((a 3) (b 2) (c 1.0)) (* 0.0 a)) + (let ((a 3) (b 2) (c 1.0)) (* c 0)) + (let ((a 3) (b 2) (c 1.0)) (* c 0.0)) + (let ((a 3) (b 2) (c 1.0)) (* 0 c)) + (let ((a 3) (b 2) (c 1.0)) (* 0.0 c)) + (let ((a 3) (b 2) (c 1.0)) (* a b 0 c 0)) + (let ((a 3) (b 2) (c 1.0)) (* 0 a)) + (let ((a 3) (b 2) (c 1.0)) (* 0 a b)) + (let ((a 3) (b 2) (c 1.0)) (* 0 a b c)) + (let ((a 3) (b 2) (c 1.0)) (* 1 2 3)) + (let ((a 3) (b 2) (c 1.0)) (* 3.0 2.0 1)) + (let ((a 3) (b 2) (c 1.0)) (* 3.0 2.0 1 4)) + (let ((a 3) (b 2) (c 1.0)) (* a 1)) + (let ((a 3) (b 2) (c 1.0)) (* a -1)) + (let ((a 3) (b 2) (c 1.0)) (* 1 a)) + (let ((a 3) (b 2) (c 1.0)) (* -1 a)) + (let ((a 3) (b 2) (c 1.0)) (* c 1)) + (let ((a 3) (b 2) (c 1.0)) (* c -1)) + (let ((a 3) (b 2) (c 1.0)) (* 1 c)) + (let ((a 3) (b 2) (c 1.0)) (* -1 c)) + (let ((a 3) (b 2) (c 1.0)) (* a b 0)) + (let ((a 3) (b 2) (c 1.0)) (* a b 1)) + (let ((a 3) (b 2) (c 1.0)) (* a b -1)) + (let ((a 3) (b 2) (c 1.0)) (* a b 2)) + (let ((a 3) (b 2) (c 1.0)) (* 1 a b c)) + (let ((a 3) (b 2) (c 1.0)) (* a b c 0)) + (let ((a 3) (b 2) (c 1.0)) (* a b c 1)) + (let ((a 3) (b 2) (c 1.0)) (* a b c -1)) + + (let ((a 3) (b 2) (c 1.0)) (/)) + (let ((a 3) (b 2) (c 1.0)) (/ 2)) + (let ((a 3) (b 2) (c 1.0)) (/ 2 0)) + (let ((a 3) (b 2) (c 1.0)) (/ 2 0.0)) + (let ((a 3) (b 2) (c 1.0)) (/ 2.0)) + (let ((a 3) (b 2) (c 1.0)) (/ 2.0 0)) + (let ((a 3) (b 2) (c 1.0)) (/ 2.0 0.0)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 2)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (/ 0.0 2)) + (let ((a 3) (b 2) (c 1.0)) (/ 0.0 2.0)) + (let ((a 3) (b 2) (c 1.0)) (/ a)) + (let ((a 3) (b 2) (c 1.0)) (/ a 0)) + (let ((a 3) (b 2) (c 1.0)) (/ a 0.0)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 a)) + (let ((a 3) (b 2) (c 1.0)) (/ 0.0 a)) + (let ((a 3) (b 2) (c 1.0)) (/ c 0)) + (let ((a 3) (b 2) (c 1.0)) (/ c 0.0)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 c)) + (let ((a 3) (b 2) (c 1.0)) (/ 0.0 c)) + (let ((a 3) (b 2) (c 1.0)) (/ a b 0 c 0)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 a)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 a b)) + (let ((a 3) (b 2) (c 1.0)) (/ 0 a b c)) + (let ((a 3) (b 2) (c 1.0)) (/ 1 2 3)) + (let ((a 3) (b 2) (c 1.0)) (/ 3.0 2.0 1)) + (let ((a 3) (b 2) (c 1.0)) (/ 3.0 2.0 1 4)) + (let ((a 3) (b 2) (c 1.0)) (/ a 1)) + (let ((a 3) (b 2) (c 1.0)) (/ a -1)) + (let ((a 3) (b 2) (c 1.0)) (/ 1 a)) + (let ((a 3) (b 2) (c 1.0)) (/ -1 a)) + (let ((a 3) (b 2) (c 1.0)) (/ c 1)) + (let ((a 3) (b 2) (c 1.0)) (/ c -1)) + (let ((a 3) (b 2) (c 1.0)) (/ 1 c)) + (let ((a 3) (b 2) (c 1.0)) (/ -1 c)) + (let ((a 3) (b 2) (c 1.0)) (/ a b 0)) + (let ((a 3) (b 2) (c 1.0)) (/ a b 1)) + (let ((a 3) (b 2) (c 1.0)) (/ a b -1)) + (let ((a 3) (b 2) (c 1.0)) (/ a b 2)) + (let ((a 3) (b 2) (c 1.0)) (/ 1 a b c)) + (let ((a 3) (b 2) (c 1.0)) (/ a b c 0)) + (let ((a 3) (b 2) (c 1.0)) (/ a b c 1)) + (let ((a 3) (b 2) (c 1.0)) (/ a b c -1))) + "List of expression for test. +Each element will be executed by interpreter and with +bytecompiled code, and their results compared.") + +(defun bytecomp-check-1 (pat) + "Return non-nil if PAT is the same whether directly evalled or compiled." + (let ((warning-minimum-log-level :emergency) + (byte-compile-warnings nil) + (v0 (condition-case nil + (eval pat) + (error nil))) + (v1 (condition-case nil + (funcall (byte-compile (list 'lambda nil pat))) + (error nil)))) + (equal v0 v1))) + +(put 'bytecomp-check-1 'ert-explainer 'bytecomp-explain-1) + +(defun bytecomp-explain-1 (pat) + (let ((v0 (condition-case nil + (eval pat) + (error nil))) + (v1 (condition-case nil + (funcall (byte-compile (list 'lambda nil pat))) + (error nil)))) + (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled." + pat v0 v1))) + +(ert-deftest bytecomp-tests () + "Test the Emacs byte compiler." + (dolist (pat byte-opt-testsuite-arith-data) + (should (bytecomp-check-1 pat)))) + +(defun test-byte-opt-arithmetic (&optional arg) + "Unit test for byte-opt arithmetic operations. +Subtests signal errors if something goes wrong." + (interactive "P") + (switch-to-buffer (generate-new-buffer "*Font Pase Test*")) + (let ((warning-minimum-log-level :emergency) + (byte-compile-warnings nil) + (pass-face '((t :foreground "green"))) + (fail-face '((t :foreground "red"))) + (print-escape-nonascii t) + (print-escape-newlines t) + (print-quoted t) + v0 v1) + (dolist (pat byte-opt-testsuite-arith-data) + (condition-case nil + (setq v0 (eval pat)) + (error (setq v0 nil))) + (condition-case nil + (setq v1 (funcall (byte-compile (list 'lambda nil pat)))) + (error (setq v1 nil))) + (insert (format "%s" pat)) + (indent-to-column 65) + (if (equal v0 v1) + (insert (propertize "OK" 'face pass-face)) + (insert (propertize "FAIL\n" 'face fail-face)) + (indent-to-column 55) + (insert (propertize (format "[%s] vs [%s]" v0 v1) + 'face fail-face))) + (insert "\n")))) + +(defun test-byte-comp-compile-and-load (compile &rest forms) + (let ((elfile nil) + (elcfile nil)) + (unwind-protect + (progn + (setf elfile (make-temp-file "test-bytecomp" nil ".el")) + (when compile + (setf elcfile (make-temp-file "test-bytecomp" nil ".elc"))) + (with-temp-buffer + (dolist (form forms) + (print form (current-buffer))) + (write-region (point-min) (point-max) elfile nil 'silent)) + (if compile + (let ((byte-compile-dest-file-function + (lambda (e) elcfile))) + (byte-compile-file elfile t)) + (load elfile nil 'nomessage))) + (when elfile (delete-file elfile)) + (when elcfile (delete-file elcfile))))) +(put 'test-byte-comp-compile-and-load 'lisp-indent-function 1) + +(ert-deftest test-byte-comp-macro-expansion () + (test-byte-comp-compile-and-load t + '(progn (defmacro abc (arg) 1) (defun def () (abc 2)))) + (should (equal (funcall 'def) 1))) + +(ert-deftest test-byte-comp-macro-expansion-eval-and-compile () + (test-byte-comp-compile-and-load t + '(eval-and-compile (defmacro abc (arg) -1) (defun def () (abc 2)))) + (should (equal (funcall 'def) -1))) + +(ert-deftest test-byte-comp-macro-expansion-eval-when-compile () + ;; Make sure we interpret eval-when-compile forms properly. CLISP + ;; and SBCL interpreter eval-when-compile (well, the CL equivalent) + ;; in the same way. + (test-byte-comp-compile-and-load t + '(eval-when-compile + (defmacro abc (arg) -10) + (defun abc-1 () (abc 2))) + '(defmacro abc-2 () (abc-1)) + '(defun def () (abc-2))) + (should (equal (funcall 'def) -10))) + +(ert-deftest test-byte-comp-macro-expand-lexical-override () + ;; Intuitively, one might expect the defmacro to override the + ;; macrolet since macrolet's is explicitly called out as being + ;; equivalent to toplevel, but CLISP and SBCL both evaluate the form + ;; this way, so we should too. + (test-byte-comp-compile-and-load t + '(require 'cl-lib) + '(cl-macrolet ((m () 4)) + (defmacro m () 5) + (defun def () (m)))) + (should (equal (funcall 'def) 4))) + +(ert-deftest bytecomp-tests--warnings () + (with-current-buffer (get-buffer-create "*Compile-Log*") + (let ((inhibit-read-only t)) (erase-buffer))) + (test-byte-comp-compile-and-load t + '(progn + (defun my-test0 () + (my--test11 3) + (my--test12 3) + (my--test2 5)) + (defmacro my--test11 (arg) (+ arg 1)) + (eval-and-compile + (defmacro my--test12 (arg) (+ arg 1)) + (defun my--test2 (arg) (+ arg 1))))) + (with-current-buffer (get-buffer-create "*Compile-Log*") + (goto-char (point-min)) + ;; Should warn that mt--test1[12] are first used as functions. + ;; The second alternative is for when the file name is so long + ;; that pretty-printing starts the message on the next line. + (should (or (re-search-forward "my--test11:\n.*macro" nil t) + (re-search-forward "my--test11:\n.*:\n.*macro" nil t))) + (should (or (re-search-forward "my--test12:\n.*macro" nil t) + (re-search-forward "my--test12:\n.*:\n.*macro" nil t))) + (goto-char (point-min)) + ;; Should not warn that mt--test2 is not known to be defined. + (should-not (re-search-forward "my--test2" nil t)))) + +(ert-deftest test-eager-load-macro-expansion () + (test-byte-comp-compile-and-load nil + '(progn (defmacro abc (arg) 1) (defun def () (abc 2)))) + (should (equal (funcall 'def) 1))) + +(ert-deftest test-eager-load-macro-expansion-eval-and-compile () + (test-byte-comp-compile-and-load nil + '(eval-and-compile (defmacro abc (arg) -1) (defun def () (abc 2)))) + (should (equal (funcall 'def) -1))) + +(ert-deftest test-eager-load-macro-expansion-eval-when-compile () + ;; Make sure we interpret eval-when-compile forms properly. CLISP + ;; and SBCL interpreter eval-when-compile (well, the CL equivalent) + ;; in the same way. + (test-byte-comp-compile-and-load nil + '(eval-when-compile + (defmacro abc (arg) -10) + (defun abc-1 () (abc 2))) + '(defmacro abc-2 () (abc-1)) + '(defun def () (abc-2))) + (should (equal (funcall 'def) -10))) + +(ert-deftest test-eager-load-macro-expand-lexical-override () + ;; Intuitively, one might expect the defmacro to override the + ;; macrolet since macrolet's is explicitly called out as being + ;; equivalent to toplevel, but CLISP and SBCL both evaluate the form + ;; this way, so we should too. + (test-byte-comp-compile-and-load nil + '(require 'cl-lib) + '(cl-macrolet ((m () 4)) + (defmacro m () 5) + (defun def () (m)))) + (should (equal (funcall 'def) 4))) + +(defconst bytecomp-lexbind-tests + `( + (let ((f #'car)) + (let ((f (lambda (x) (cons (funcall f x) (cdr x))))) + (funcall f '(1 . 2)))) + ) + "List of expression for test. +Each element will be executed by interpreter and with +bytecompiled code, and their results compared.") + +(defun bytecomp-lexbind-check-1 (pat) + "Return non-nil if PAT is the same whether directly evalled or compiled." + (let ((warning-minimum-log-level :emergency) + (byte-compile-warnings nil) + (v0 (condition-case nil + (eval pat t) + (error nil))) + (v1 (condition-case nil + (funcall (let ((lexical-binding t)) + (byte-compile `(lambda nil ,pat)))) + (error nil)))) + (equal v0 v1))) + +(put 'bytecomp-lexbind-check-1 'ert-explainer 'bytecomp-lexbind-explain-1) + +(defun bytecomp-lexbind-explain-1 (pat) + (let ((v0 (condition-case nil + (eval pat t) + (error nil))) + (v1 (condition-case nil + (funcall (let ((lexical-binding t)) + (byte-compile (list 'lambda nil pat)))) + (error nil)))) + (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled." + pat v0 v1))) + +(ert-deftest bytecomp-lexbind-tests () + "Test the Emacs byte compiler lexbind handling." + (dolist (pat bytecomp-lexbind-tests) + (should (bytecomp-lexbind-check-1 pat)))) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +(provide 'bytecomp-tests) +;; bytecomp-tests.el ends here. diff --cc test/lisp/emacs-lisp/cl-generic-tests.el index dee10fe285e,00000000000..0768e31f7e6 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/cl-generic-tests.el +++ b/test/lisp/emacs-lisp/cl-generic-tests.el @@@ -1,223 -1,0 +1,223 @@@ +;;; cl-generic-tests.el --- Tests for cl-generic.el functionality -*- lexical-binding: t; -*- + - ;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2017 Free Software Foundation, Inc. + +;; Author: Stefan Monnier + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(eval-when-compile (require 'ert)) ;Don't indirectly require cl-lib at run-time. +(require 'cl-generic) + +(fmakunbound 'cl--generic-1) +(cl-defgeneric cl--generic-1 (x y)) +(cl-defgeneric (setf cl--generic-1) (v y z) "My generic doc.") + +(ert-deftest cl-generic-test-00 () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y)) + (cl-defmethod cl--generic-1 ((x t) y) (cons x y)) + (should (equal (cl--generic-1 'a 'b) '(a . b)))) + +(ert-deftest cl-generic-test-01-eql () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y)) + (cl-defmethod cl--generic-1 ((x t) y) (cons x y)) + (cl-defmethod cl--generic-1 ((_x (eql 4)) _y) + (cons "quatre" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x (eql 5)) _y) + (cons "cinq" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x (eql 6)) y) + (cons "six" (cl-call-next-method 'a y))) + (should (equal (cl--generic-1 'a nil) '(a))) + (should (equal (cl--generic-1 4 nil) '("quatre" 4))) + (should (equal (cl--generic-1 5 nil) '("cinq" 5))) + (should (equal (cl--generic-1 6 nil) '("six" a)))) + +(cl-defstruct cl-generic-struct-parent a b) +(cl-defstruct (cl-generic-struct-child1 (:include cl-generic-struct-parent)) c) +(cl-defstruct (cl-generic-struct-child11 (:include cl-generic-struct-child1)) d) +(cl-defstruct (cl-generic-struct-child2 (:include cl-generic-struct-parent)) e) + +(ert-deftest cl-generic-test-02-struct () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y) "My doc.") + (cl-defmethod cl--generic-1 ((x t) y) "Doc 1." (cons x y)) + (cl-defmethod cl--generic-1 ((_x cl-generic-struct-parent) y) + "Doc 2." (cons "parent" (cl-call-next-method 'a y))) + (cl-defmethod cl--generic-1 ((_x cl-generic-struct-child1) _y) + (cons "child1" (cl-call-next-method))) + (cl-defmethod cl--generic-1 :around ((_x t) _y) + (cons "around" (cl-call-next-method))) + (cl-defmethod cl--generic-1 :around ((_x cl-generic-struct-child11) _y) + (cons "child11" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x cl-generic-struct-child2) _y) + (cons "child2" (cl-call-next-method))) + (should (equal (cl--generic-1 (make-cl-generic-struct-child1) nil) + '("around" "child1" "parent" a))) + (should (equal (cl--generic-1 (make-cl-generic-struct-child2) nil) + '("around""child2" "parent" a))) + (should (equal (cl--generic-1 (make-cl-generic-struct-child11) nil) + '("child11" "around""child1" "parent" a)))) + +;; I don't know how to put this inside an `ert-test'. This tests that `setf' +;; can be used directly inside the body of the setf method. +(cl-defmethod (setf cl--generic-2) (v (y integer) z) + (setf (cl--generic-2 (nth y z) z) v)) + +(ert-deftest cl-generic-test-03-setf () + (cl-defmethod (setf cl--generic-1) (v (y t) z) (list v y z)) + (cl-defmethod (setf cl--generic-1) (v (_y (eql 4)) z) (list v "four" z)) + (should (equal (setf (cl--generic-1 'a 'b) 'v) '(v a b))) + (should (equal (setf (cl--generic-1 4 'b) 'v) '(v "four" b))) + (let ((x ())) + (should (equal (setf (cl--generic-1 (progn (push 1 x) 'a) + (progn (push 2 x) 'b)) + (progn (push 3 x) 'v)) + '(v a b))) + (should (equal x '(3 2 1))))) + +(ert-deftest cl-generic-test-04-overlapping-tagcodes () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y) "My doc.") + (cl-defmethod cl--generic-1 ((y t) z) (list y z)) + (cl-defmethod cl--generic-1 ((_y (eql 4)) _z) + (cons "four" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_y integer) _z) + (cons "integer" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_y number) _z) + (cons "number" (cl-call-next-method))) + (should (equal (cl--generic-1 'a 'b) '(a b))) + (should (equal (cl--generic-1 1 'b) '("integer" "number" 1 b))) + (should (equal (cl--generic-1 4 'b) '("four" "integer" "number" 4 b)))) + +(ert-deftest cl-generic-test-05-alias () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y) "My doc.") + (defalias 'cl--generic-2 #'cl--generic-1) + (cl-defmethod cl--generic-1 ((y t) z) (list y z)) + (cl-defmethod cl--generic-2 ((_y (eql 4)) _z) + (cons "four" (cl-call-next-method))) + (should (equal (cl--generic-1 4 'b) '("four" 4 b)))) + +(ert-deftest cl-generic-test-06-multiple-dispatch () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y) "My doc.") + (cl-defmethod cl--generic-1 (x y) (list x y)) + (cl-defmethod cl--generic-1 (_x (_y integer)) + (cons "y-int" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x integer) _y) + (cons "x-int" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x integer) (_y integer)) + (cons "x&y-int" (cl-call-next-method))) + (should (equal (cl--generic-1 1 2) '("x&y-int" "x-int" "y-int" 1 2)))) + +(ert-deftest cl-generic-test-07-apo () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y) + (:documentation "My doc.") (:argument-precedence-order y x)) + (cl-defmethod cl--generic-1 (x y) (list x y)) + (cl-defmethod cl--generic-1 (_x (_y integer)) + (cons "y-int" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x integer) _y) + (cons "x-int" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x integer) (_y integer)) + (cons "x&y-int" (cl-call-next-method))) + (should (equal (cl--generic-1 1 2) '("x&y-int" "y-int" "x-int" 1 2)))) + +(ert-deftest cl-generic-test-08-after/before () + (let ((log ())) + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y)) + (cl-defmethod cl--generic-1 ((_x t) y) (cons y log)) + (cl-defmethod cl--generic-1 ((_x (eql 4)) _y) + (cons "quatre" (cl-call-next-method))) + (cl-defmethod cl--generic-1 :after (x _y) + (push (list :after x) log)) + (cl-defmethod cl--generic-1 :before (x _y) + (push (list :before x) log)) + (should (equal (cl--generic-1 4 6) '("quatre" 6 (:before 4)))) + (should (equal log '((:after 4) (:before 4)))))) + +(defun cl--generic-test-advice (&rest args) (cons "advice" (apply args))) + +(ert-deftest cl-generic-test-09-advice () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y) "My doc.") + (cl-defmethod cl--generic-1 (x y) (list x y)) + (advice-add 'cl--generic-1 :around #'cl--generic-test-advice) + (should (equal (cl--generic-1 4 5) '("advice" 4 5))) + (cl-defmethod cl--generic-1 ((_x integer) _y) + (cons "integer" (cl-call-next-method))) + (should (equal (cl--generic-1 4 5) '("advice" "integer" 4 5))) + (advice-remove 'cl--generic-1 #'cl--generic-test-advice) + (should (equal (cl--generic-1 4 5) '("integer" 4 5)))) + +(ert-deftest cl-generic-test-10-weird () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x &rest r) "My doc.") + (cl-defmethod cl--generic-1 (x &rest r) (cons x r)) + ;; This kind of definition is not valid according to CLHS, but it does show + ;; up in EIEIO's tests for no-next-method, so we should either + ;; detect it and signal an error or do something meaningful with it. + (cl-defmethod cl--generic-1 (x (y integer) &rest r) + `("integer" ,y ,x ,@r)) + (should (equal (cl--generic-1 'a 'b) '(a b))) + (should (equal (cl--generic-1 1 2) '("integer" 2 1)))) + +(ert-deftest cl-generic-test-11-next-method-p () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y)) + (cl-defmethod cl--generic-1 ((x t) y) + (list x y (cl-next-method-p))) + (cl-defmethod cl--generic-1 ((_x (eql 4)) _y) + (cl-list* "quatre" (cl-next-method-p) (cl-call-next-method))) + (should (equal (cl--generic-1 4 5) '("quatre" t 4 5 nil)))) + +(ert-deftest cl-generic-test-12-context () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 ()) + (cl-defmethod cl--generic-1 (&context (overwrite-mode (eql t))) + (list 'is-t (cl-call-next-method))) + (cl-defmethod cl--generic-1 (&context (overwrite-mode (eql nil))) + (list 'is-nil (cl-call-next-method))) + (cl-defmethod cl--generic-1 () 'any) + (should (equal (list (let ((overwrite-mode t)) (cl--generic-1)) + (let ((overwrite-mode nil)) (cl--generic-1)) + (let ((overwrite-mode 1)) (cl--generic-1))) + '((is-t any) (is-nil any) any)))) + +(ert-deftest cl-generic-test-13-head () + (fmakunbound 'cl--generic-1) + (cl-defgeneric cl--generic-1 (x y)) + (cl-defmethod cl--generic-1 ((x t) y) (cons x y)) + (cl-defmethod cl--generic-1 ((_x (head 4)) _y) + (cons "quatre" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x (head 5)) _y) + (cons "cinq" (cl-call-next-method))) + (cl-defmethod cl--generic-1 ((_x (head 6)) y) + (cons "six" (cl-call-next-method 'a y))) + (should (equal (cl--generic-1 'a nil) '(a))) + (should (equal (cl--generic-1 '(4) nil) '("quatre" (4)))) + (should (equal (cl--generic-1 '(5) nil) '("cinq" (5)))) + (should (equal (cl--generic-1 '(6) nil) '("six" a)))) + +(provide 'cl-generic-tests) +;;; cl-generic-tests.el ends here diff --cc test/lisp/emacs-lisp/cl-lib-tests.el index cbaf70fc4bb,00000000000..5edc3e72bf2 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@@ -1,496 -1,0 +1,496 @@@ +;;; cl-lib.el --- tests for emacs-lisp/cl-lib.el -*- lexical-binding:t -*- + - ;; Copyright (C) 2013-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; Extracted from ert-tests.el, back when ert used to reimplement some +;; cl functions. + +;;; Code: + +(require 'cl-lib) +(require 'ert) + +(ert-deftest cl-lib-test-remprop () + (let ((x (cl-gensym))) + (should (equal (symbol-plist x) '())) + ;; Remove nonexistent property on empty plist. + (cl-remprop x 'b) + (should (equal (symbol-plist x) '())) + (put x 'a 1) + (should (equal (symbol-plist x) '(a 1))) + ;; Remove nonexistent property on nonempty plist. + (cl-remprop x 'b) + (should (equal (symbol-plist x) '(a 1))) + (put x 'b 2) + (put x 'c 3) + (put x 'd 4) + (should (equal (symbol-plist x) '(a 1 b 2 c 3 d 4))) + ;; Remove property that is neither first nor last. + (cl-remprop x 'c) + (should (equal (symbol-plist x) '(a 1 b 2 d 4))) + ;; Remove last property from a plist of length >1. + (cl-remprop x 'd) + (should (equal (symbol-plist x) '(a 1 b 2))) + ;; Remove first property from a plist of length >1. + (cl-remprop x 'a) + (should (equal (symbol-plist x) '(b 2))) + ;; Remove property when there is only one. + (cl-remprop x 'b) + (should (equal (symbol-plist x) '())))) + +(ert-deftest cl-lib-test-remove-if-not () + (let ((list (list 'a 'b 'c 'd)) + (i 0)) + (let ((result (cl-remove-if-not (lambda (x) + (should (eql x (nth i list))) + (cl-incf i) + (member i '(2 3))) + list))) + (should (equal i 4)) + (should (equal result '(b c))) + (should (equal list '(a b c d))))) + (should (equal '() + (cl-remove-if-not (lambda (_x) (should nil)) '())))) + +(ert-deftest cl-lib-test-remove () + (let ((list (list 'a 'b 'c 'd)) + (key-index 0) + (test-index 0)) + (let ((result + (cl-remove 'foo list + :key (lambda (x) + (should (eql x (nth key-index list))) + (prog1 + (list key-index x) + (cl-incf key-index))) + :test + (lambda (a b) + (should (eql a 'foo)) + (should (equal b (list test-index + (nth test-index list)))) + (cl-incf test-index) + (member test-index '(2 3)))))) + (should (equal key-index 4)) + (should (equal test-index 4)) + (should (equal result '(a d))) + (should (equal list '(a b c d))))) + (let ((x (cons nil nil)) + (y (cons nil nil))) + (should (equal (cl-remove x (list x y)) + ;; or (list x), since we use `equal' -- the + ;; important thing is that only one element got + ;; removed, this proves that the default test is + ;; `eql', not `equal' + (list y))))) + + +(ert-deftest cl-lib-test-set-functions () + (let ((c1 (cons nil nil)) + (c2 (cons nil nil)) + (sym (make-symbol "a"))) + (let ((e '()) + (a (list 'a 'b sym nil "" "x" c1 c2)) + (b (list c1 'y 'b sym 'x))) + (should (equal (cl-set-difference e e) e)) + (should (equal (cl-set-difference a e) a)) + (should (equal (cl-set-difference e a) e)) + (should (equal (cl-set-difference a a) e)) + (should (equal (cl-set-difference b e) b)) + (should (equal (cl-set-difference e b) e)) + (should (equal (cl-set-difference b b) e)) + ;; Note: this test (and others) is sensitive to the order of the + ;; result, which is not documented. + (should (equal (cl-set-difference a b) (list 'a nil "" "x" c2))) + (should (equal (cl-set-difference b a) (list 'y 'x))) + + ;; We aren't testing whether this is really using `eq' rather than `eql'. + (should (equal (cl-set-difference e e :test 'eq) e)) + (should (equal (cl-set-difference a e :test 'eq) a)) + (should (equal (cl-set-difference e a :test 'eq) e)) + (should (equal (cl-set-difference a a :test 'eq) e)) + (should (equal (cl-set-difference b e :test 'eq) b)) + (should (equal (cl-set-difference e b :test 'eq) e)) + (should (equal (cl-set-difference b b :test 'eq) e)) + (should (equal (cl-set-difference a b :test 'eq) (list 'a nil "" "x" c2))) + (should (equal (cl-set-difference b a :test 'eq) (list 'y 'x))) + + (should (equal (cl-union e e) e)) + (should (equal (cl-union a e) a)) + (should (equal (cl-union e a) a)) + (should (equal (cl-union a a) a)) + (should (equal (cl-union b e) b)) + (should (equal (cl-union e b) b)) + (should (equal (cl-union b b) b)) + (should (equal (cl-union a b) (list 'x 'y 'a 'b sym nil "" "x" c1 c2))) + + (should (equal (cl-union b a) (list 'x 'y 'a 'b sym nil "" "x" c1 c2))) + + (should (equal (cl-intersection e e) e)) + (should (equal (cl-intersection a e) e)) + (should (equal (cl-intersection e a) e)) + (should (equal (cl-intersection a a) a)) + (should (equal (cl-intersection b e) e)) + (should (equal (cl-intersection e b) e)) + (should (equal (cl-intersection b b) b)) + (should (equal (cl-intersection a b) (list sym 'b c1))) + (should (equal (cl-intersection b a) (list sym 'b c1)))))) + +(ert-deftest cl-lib-test-gensym () + ;; Since the expansion of `should' calls `cl-gensym' and thus has a + ;; side-effect on `cl--gensym-counter', we have to make sure all + ;; macros in our test body are expanded before we rebind + ;; `cl--gensym-counter' and run the body. Otherwise, the test would + ;; fail if run interpreted. + (let ((body (byte-compile + '(lambda () + (should (equal (symbol-name (cl-gensym)) "G0")) + (should (equal (symbol-name (cl-gensym)) "G1")) + (should (equal (symbol-name (cl-gensym)) "G2")) + (should (equal (symbol-name (cl-gensym "foo")) "foo3")) + (should (equal (symbol-name (cl-gensym "bar")) "bar4")) + (should (equal cl--gensym-counter 5)))))) + (let ((cl--gensym-counter 0)) + (funcall body)))) + +(ert-deftest cl-lib-test-coerce-to-vector () + (let* ((a (vector)) + (b (vector 1 a 3)) + (c (list)) + (d (list b a))) + (should (eql (cl-coerce a 'vector) a)) + (should (eql (cl-coerce b 'vector) b)) + (should (equal (cl-coerce c 'vector) (vector))) + (should (equal (cl-coerce d 'vector) (vector b a))))) + +(ert-deftest cl-lib-test-string-position () + (should (eql (cl-position ?x "") nil)) + (should (eql (cl-position ?a "abc") 0)) + (should (eql (cl-position ?b "abc") 1)) + (should (eql (cl-position ?c "abc") 2)) + (should (eql (cl-position ?d "abc") nil)) + (should (eql (cl-position ?A "abc") nil))) + +(ert-deftest cl-lib-test-mismatch () + (should (eql (cl-mismatch "" "") nil)) + (should (eql (cl-mismatch "" "a") 0)) + (should (eql (cl-mismatch "a" "a") nil)) + (should (eql (cl-mismatch "ab" "a") 1)) + (should (eql (cl-mismatch "Aa" "aA") 0)) + (should (eql (cl-mismatch '(a b c) '(a b d)) 2))) + +(ert-deftest cl-lib-test-loop () + (should (eql (cl-loop with (a b c) = '(1 2 3) return (+ a b c)) 6))) + +(ert-deftest cl-lib-keyword-names-versus-values () + (should (equal + (funcall (cl-function (lambda (&key a b) (list a b))) + :b :a :a 42) + '(42 :a)))) + +(cl-defstruct (mystruct + (:constructor cl-lib--con-1 (&aux (abc 1))) + (:constructor cl-lib--con-2 (&optional def) "Constructor docstring.")) + "General docstring." + (abc 5 :readonly t) (def nil)) +(ert-deftest cl-lib-struct-accessors () + (let ((x (make-mystruct :abc 1 :def 2))) + (should (eql (cl-struct-slot-value 'mystruct 'abc x) 1)) + (should (eql (cl-struct-slot-value 'mystruct 'def x) 2)) + (setf (cl-struct-slot-value 'mystruct 'def x) -1) + (should (eql (cl-struct-slot-value 'mystruct 'def x) -1)) + (should (eql (cl-struct-slot-offset 'mystruct 'abc) 1)) + (should-error (cl-struct-slot-offset 'mystruct 'marypoppins)) + (should (pcase (cl-struct-slot-info 'mystruct) + (`((cl-tag-slot) (abc 5 :readonly t) + (def . ,(or `nil `(nil)))) + t))))) +(ert-deftest cl-lib-struct-constructors () + (should (string-match "\\`Constructor docstring." + (documentation 'cl-lib--con-2 t))) + (should (mystruct-p (cl-lib--con-1))) + (should (mystruct-p (cl-lib--con-2)))) + +(ert-deftest cl-lib-arglist-performance () + ;; An `&aux' should not cause lambda's arglist to be turned into an &rest + ;; that's parsed by hand. + (should (equal () (help-function-arglist 'cl-lib--con-1))) + (should (pcase (help-function-arglist 'cl-lib--con-2) + (`(&optional ,_) t)))) + +(ert-deftest cl-the () + (should (eql (cl-the integer 42) 42)) + (should-error (cl-the integer "abc")) + (let ((side-effect 0)) + (should (= (cl-the integer (cl-incf side-effect)) 1)) + (should (= side-effect 1)))) + +(ert-deftest cl-lib-test-plusp () + (should-not (cl-plusp -1.0e+INF)) + (should-not (cl-plusp -1.5e2)) + (should-not (cl-plusp -3.14)) + (should-not (cl-plusp -1)) + (should-not (cl-plusp -0.0)) + (should-not (cl-plusp 0)) + (should-not (cl-plusp 0.0)) + (should-not (cl-plusp -0.0e+NaN)) + (should-not (cl-plusp 0.0e+NaN)) + (should (cl-plusp 1)) + (should (cl-plusp 3.14)) + (should (cl-plusp 1.5e2)) + (should (cl-plusp 1.0e+INF)) + (should-error (cl-plusp "42") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-minusp () + (should (cl-minusp -1.0e+INF)) + (should (cl-minusp -1.5e2)) + (should (cl-minusp -3.14)) + (should (cl-minusp -1)) + (should-not (cl-minusp -0.0)) + (should-not (cl-minusp 0)) + (should-not (cl-minusp 0.0)) + (should-not (cl-minusp -0.0e+NaN)) + (should-not (cl-minusp 0.0e+NaN)) + (should-not (cl-minusp 1)) + (should-not (cl-minusp 3.14)) + (should-not (cl-minusp 1.5e2)) + (should-not (cl-minusp 1.0e+INF)) + (should-error (cl-minusp "-42") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-oddp () + (should (cl-oddp -3)) + (should (cl-oddp 3)) + (should-not (cl-oddp -2)) + (should-not (cl-oddp 0)) + (should-not (cl-oddp 2)) + (should-error (cl-oddp 3.0e+NaN) :type 'wrong-type-argument) + (should-error (cl-oddp 3.0) :type 'wrong-type-argument) + (should-error (cl-oddp "3") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-evenp () + (should (cl-evenp -2)) + (should (cl-evenp 0)) + (should (cl-evenp 2)) + (should-not (cl-evenp -3)) + (should-not (cl-evenp 3)) + (should-error (cl-evenp 2.0e+NaN) :type 'wrong-type-argument) + (should-error (cl-evenp 2.0) :type 'wrong-type-argument) + (should-error (cl-evenp "2") :type 'wrong-type-argument)) + +(ert-deftest cl-digit-char-p () + (should (eql 3 (cl-digit-char-p ?3))) + (should (eql 10 (cl-digit-char-p ?a 11))) + (should (eql 10 (cl-digit-char-p ?A 11))) + (should-not (cl-digit-char-p ?a)) + (should (eql 32 (cl-digit-char-p ?w 36))) + (should-error (cl-digit-char-p ?a 37) :type 'args-out-of-range) + (should-error (cl-digit-char-p ?a 1) :type 'args-out-of-range)) + +(ert-deftest cl-lib-test-first () + (should (null (cl-first '()))) + (should (= 4 (cl-first '(4)))) + (should (= 4 (cl-first '(4 2)))) + (should-error (cl-first "42") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-second () + (should (null (cl-second '()))) + (should (null (cl-second '(4)))) + (should (= 2 (cl-second '(1 2)))) + (should (= 2 (cl-second '(1 2 3)))) + (should-error (cl-second "1 2 3") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-third () + (should (null (cl-third '()))) + (should (null (cl-third '(1 2)))) + (should (= 3 (cl-third '(1 2 3)))) + (should (= 3 (cl-third '(1 2 3 4)))) + (should-error (cl-third "123") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-fourth () + (should (null (cl-fourth '()))) + (should (null (cl-fourth '(1 2 3)))) + (should (= 4 (cl-fourth '(1 2 3 4)))) + (should (= 4 (cl-fourth '(1 2 3 4 5)))) + (should-error (cl-fourth "1234") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-fifth () + (should (null (cl-fifth '()))) + (should (null (cl-fifth '(1 2 3 4)))) + (should (= 5 (cl-fifth '(1 2 3 4 5)))) + (should (= 5 (cl-fifth '(1 2 3 4 5 6)))) + (should-error (cl-fifth "12345") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-fifth () + (should (null (cl-fifth '()))) + (should (null (cl-fifth '(1 2 3 4)))) + (should (= 5 (cl-fifth '(1 2 3 4 5)))) + (should (= 5 (cl-fifth '(1 2 3 4 5 6)))) + (should-error (cl-fifth "12345") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-sixth () + (should (null (cl-sixth '()))) + (should (null (cl-sixth '(1 2 3 4 5)))) + (should (= 6 (cl-sixth '(1 2 3 4 5 6)))) + (should (= 6 (cl-sixth '(1 2 3 4 5 6 7)))) + (should-error (cl-sixth "123456") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-seventh () + (should (null (cl-seventh '()))) + (should (null (cl-seventh '(1 2 3 4 5 6)))) + (should (= 7 (cl-seventh '(1 2 3 4 5 6 7)))) + (should (= 7 (cl-seventh '(1 2 3 4 5 6 7 8)))) + (should-error (cl-seventh "1234567") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-eighth () + (should (null (cl-eighth '()))) + (should (null (cl-eighth '(1 2 3 4 5 6 7)))) + (should (= 8 (cl-eighth '(1 2 3 4 5 6 7 8)))) + (should (= 8 (cl-eighth '(1 2 3 4 5 6 7 8 9)))) + (should-error (cl-eighth "12345678") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-ninth () + (should (null (cl-ninth '()))) + (should (null (cl-ninth '(1 2 3 4 5 6 7 8)))) + (should (= 9 (cl-ninth '(1 2 3 4 5 6 7 8 9)))) + (should (= 9 (cl-ninth '(1 2 3 4 5 6 7 8 9 10)))) + (should-error (cl-ninth "123456789") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-tenth () + (should (null (cl-tenth '()))) + (should (null (cl-tenth '(1 2 3 4 5 6 7 8 9)))) + (should (= 10 (cl-tenth '(1 2 3 4 5 6 7 8 9 10)))) + (should (= 10 (cl-tenth '(1 2 3 4 5 6 7 8 9 10 11)))) + (should-error (cl-tenth "1234567890") :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-endp () + (should (cl-endp '())) + (should-not (cl-endp '(1))) + (should-error (cl-endp 1) :type 'wrong-type-argument) + (should-error (cl-endp [1]) :type 'wrong-type-argument)) + +(ert-deftest cl-lib-test-nth-value () + (let ((vals (cl-values 2 3))) + (should (= (cl-nth-value 0 vals) 2)) + (should (= (cl-nth-value 1 vals) 3)) + (should (null (cl-nth-value 2 vals))) + (should-error (cl-nth-value 0.0 vals) :type 'wrong-type-argument))) + +(ert-deftest cl-lib-nth-value-test-multiple-values () + "While CL multiple values are an alias to list, these won't work." + :expected-result :failed + (should (eq (cl-nth-value 0 '(2 3)) '(2 3))) + (should (= (cl-nth-value 0 1) 1)) + (should (null (cl-nth-value 1 1))) + (should-error (cl-nth-value -1 (cl-values 2 3)) :type 'args-out-of-range) + (should (string= (cl-nth-value 0 "only lists") "only lists"))) + +(ert-deftest cl-test-caaar () + (should (null (cl-caaar '()))) + (should (null (cl-caaar '(() (2))))) + (should (null (cl-caaar '((() (2)) (a b))))) + (should-error (cl-caaar '(1 2)) :type 'wrong-type-argument) + (should-error (cl-caaar '((1 2))) :type 'wrong-type-argument) + (should (= 1 (cl-caaar '(((1 2) (3 4)))))) + (should (null (cl-caaar '((() (3 4))))))) + +(ert-deftest cl-test-caadr () + (should (null (cl-caadr '()))) + (should (null (cl-caadr '(1)))) + (should-error (cl-caadr '(1 2)) :type 'wrong-type-argument) + (should (= 2 (cl-caadr '(1 (2 3))))) + (should (equal '((2) (3)) (cl-caadr '((1) (((2) (3))) (4)))))) + +(ert-deftest cl-test-ldiff () + (let ((l '(1 2 3))) + (should (null (cl-ldiff '() '()))) + (should (null (cl-ldiff '() l))) + (should (null (cl-ldiff l l))) + (should (equal l (cl-ldiff l '()))) + ;; must be part of the list + (should (equal l (cl-ldiff l '(2 3)))) + (should (equal '(1) (cl-ldiff l (nthcdr 1 l)))) + ;; should return a copy + (should-not (eq (cl-ldiff l '()) l)))) + +(ert-deftest cl-lib-adjoin-test () + (let ((nums '(1 2)) + (myfn-p '=)) + ;; add non-existing item to the front + (should (equal '(3 1 2) (cl-adjoin 3 nums))) + ;; just add - don't copy rest + (should (eq nums (cdr (cl-adjoin 3 nums)))) + ;; add only when not already there + (should (eq nums (cl-adjoin 2 nums))) + (should (equal '(2 1 (2)) (cl-adjoin 2 '(1 (2))))) + ;; default test function is eql + (should (equal '(1.0 1 2) (cl-adjoin 1.0 nums))) + ;; own :test function - returns true if match + (should (equal '(1.0 1 2) (cl-adjoin 1.0 nums :test nil))) ;defaults to eql + (should (eq nums (cl-adjoin 2 nums :test myfn-p))) ;match + (should (equal '(3 1 2) (cl-adjoin 3 nums :test myfn-p))) ;no match + ;; own :test-not function - returns false if match + (should (equal '(1.0 1 2) (cl-adjoin 1.0 nums :test-not nil))) ;defaults to eql + (should (equal '(2 2) (cl-adjoin 2 '(2) :test-not myfn-p))) ; no match + (should (eq nums (cl-adjoin 2 nums :test-not myfn-p))) ; 1 matches + (should (eq nums (cl-adjoin 3 nums :test-not myfn-p))) ; 1 and 2 matches + + ;; according to CLtL2 passing both :test and :test-not should signal error + ;;(should-error (cl-adjoin 3 nums :test 'myfn-p :test-not myfn-p)) + + ;; own :key fn + (should (eq nums (cl-adjoin 3 nums :key (lambda (x) (if (cl-evenp x) (1+ x) x))))) + (should (equal '(3 1 2) (cl-adjoin 3 nums :key (lambda (x) (if (cl-evenp x) (+ 2 x) x))))) + + ;; convert using :key, then compare with :test + (should (eq nums (cl-adjoin 1 nums :key 'int-to-string :test 'string=))) + (should (equal '(3 1 2) (cl-adjoin 3 nums :key 'int-to-string :test 'string=))) + (should-error (cl-adjoin 3 nums :key 'int-to-string :test myfn-p) + :type 'wrong-type-argument) + + ;; convert using :key, then compare with :test-not + (should (eq nums (cl-adjoin 3 nums :key 'int-to-string :test-not 'string=))) + (should (equal '(1 1) (cl-adjoin 1 '(1) :key 'int-to-string :test-not 'string=))) + (should-error (cl-adjoin 1 nums :key 'int-to-string :test-not myfn-p) + :type 'wrong-type-argument))) + +(ert-deftest cl-parse-integer () + (should-error (cl-parse-integer "abc")) + (should (null (cl-parse-integer "abc" :junk-allowed t))) + (should (null (cl-parse-integer "" :junk-allowed t))) + (should (= 342391 (cl-parse-integer "0123456789" :radix 8 :junk-allowed t))) + (should-error (cl-parse-integer "0123456789" :radix 8)) + (should (= -239 (cl-parse-integer "-efz" :radix 16 :junk-allowed t))) + (should-error (cl-parse-integer "efz" :radix 16)) + (should (= 239 (cl-parse-integer "zzef" :radix 16 :start 2))) + (should (= -123 (cl-parse-integer " -123 ")))) + +(ert-deftest cl-loop-destructuring-with () + (should (equal (cl-loop with (a b c) = '(1 2 3) return (+ a b c)) 6))) + +(ert-deftest cl-flet-test () + (should (equal (cl-flet ((f1 (x) x)) (let ((x #'f1)) (funcall x 5))) 5))) + +(ert-deftest cl-lib-test-typep () + (cl-deftype cl-lib-test-type (&optional x) `(member ,x)) + ;; Make sure we correctly implement the rule that deftype's optional args + ;; default to `*' rather than to nil. + (should (cl-typep '* 'cl-lib-test-type)) + (should-not (cl-typep 1 'cl-lib-test-type))) + +;;; cl-lib.el ends here diff --cc test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el index eb26047da2f,00000000000..09edea461d1 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el @@@ -1,402 -1,0 +1,402 @@@ +;;; eieio-testsinvoke.el -- eieio tests for method invocation + - ;; Copyright (C) 2005, 2008, 2010, 2013-2016 Free Software Foundation, ++;; Copyright (C) 2005, 2008, 2010, 2013-2017 Free Software Foundation, +;; Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Test method invocation order. From the common lisp reference +;; manual: +;; +;; QUOTE: +;; - All the :before methods are called, in most-specific-first +;; order. Their values are ignored. An error is signaled if +;; call-next-method is used in a :before method. +;; +;; - The most specific primary method is called. Inside the body of a +;; primary method, call-next-method may be used to call the next +;; most specific primary method. When that method returns, the +;; previous primary method can execute more code, perhaps based on +;; the returned value or values. The generic function no-next-method +;; is invoked if call-next-method is used and there are no more +;; applicable primary methods. The function next-method-p may be +;; used to determine whether a next method exists. If +;; call-next-method is not used, only the most specific primary +;; method is called. +;; +;; - All the :after methods are called, in most-specific-last order. +;; Their values are ignored. An error is signaled if +;; call-next-method is used in a :after method. +;; +;; +;; Also test behavior of `call-next-method'. From clos.org: +;; +;; QUOTE: +;; When call-next-method is called with no arguments, it passes the +;; current method's original arguments to the next method. + +(require 'eieio) +(require 'ert) + +(defvar eieio-test-method-order-list nil + "List of symbols stored during method invocation.") + +(defun eieio-test-method-store (&rest args) + "Store current invocation class symbol in the invocation order list." + (push args eieio-test-method-order-list)) + +(defun eieio-test-match (rightanswer) + "Do a test match." + (if (equal rightanswer eieio-test-method-order-list) + t + (error "eieio-test-methodinvoke.el: Test Failed: %S != %S" + rightanswer eieio-test-method-order-list))) + +(defvar eieio-test-call-next-method-arguments nil + "List of passed to methods during execution of `call-next-method'.") + +(defun eieio-test-arguments-for (class) + "Returns arguments passed to method of CLASS during `call-next-method'." + (cdr (assoc class eieio-test-call-next-method-arguments))) + +(defclass eitest-A () ()) +(defclass eitest-AA (eitest-A) ()) +(defclass eitest-AAA (eitest-AA) ()) +(defclass eitest-B-base1 () ()) +(defclass eitest-B-base2 () ()) +(defclass eitest-B (eitest-B-base1 eitest-B-base2) ()) + +(defmethod eitest-F :BEFORE ((p eitest-B-base1)) + (eieio-test-method-store :BEFORE 'eitest-B-base1)) + +(defmethod eitest-F :BEFORE ((p eitest-B-base2)) + (eieio-test-method-store :BEFORE 'eitest-B-base2)) + +(defmethod eitest-F :BEFORE ((p eitest-B)) + (eieio-test-method-store :BEFORE 'eitest-B)) + +(defmethod eitest-F ((p eitest-B)) + (eieio-test-method-store :PRIMARY 'eitest-B) + (call-next-method)) + +(defmethod eitest-F ((p eitest-B-base1)) + (eieio-test-method-store :PRIMARY 'eitest-B-base1) + (call-next-method)) + +(defmethod eitest-F ((p eitest-B-base2)) + (eieio-test-method-store :PRIMARY 'eitest-B-base2) + (when (next-method-p) + (call-next-method)) + ) + +(defmethod eitest-F :AFTER ((p eitest-B-base1)) + (eieio-test-method-store :AFTER 'eitest-B-base1)) + +(defmethod eitest-F :AFTER ((p eitest-B-base2)) + (eieio-test-method-store :AFTER 'eitest-B-base2)) + +(defmethod eitest-F :AFTER ((p eitest-B)) + (eieio-test-method-store :AFTER 'eitest-B)) + +(ert-deftest eieio-test-method-order-list-3 () + (let ((eieio-test-method-order-list nil) + (ans '( + (:BEFORE eitest-B) + (:BEFORE eitest-B-base1) + (:BEFORE eitest-B-base2) + + (:PRIMARY eitest-B) + (:PRIMARY eitest-B-base1) + (:PRIMARY eitest-B-base2) + + (:AFTER eitest-B-base2) + (:AFTER eitest-B-base1) + (:AFTER eitest-B) + ))) + (eitest-F (eitest-B nil)) + (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) + (eieio-test-match ans))) + +;;; Test static invocation +;; +(defmethod eitest-H :STATIC ((class eitest-A)) + "No need to do work in here." + 'moose) + +(ert-deftest eieio-test-method-order-list-4 () + ;; Both of these situations should succeed. + (should (eitest-H 'eitest-A)) + (should (eitest-H (eitest-A nil)))) + +;;; Return value from :PRIMARY +;; +(defmethod eitest-I :BEFORE ((a eitest-A)) + (eieio-test-method-store :BEFORE 'eitest-A) + ":before") + +(defmethod eitest-I :PRIMARY ((a eitest-A)) + (eieio-test-method-store :PRIMARY 'eitest-A) + ":primary") + +(defmethod eitest-I :AFTER ((a eitest-A)) + (eieio-test-method-store :AFTER 'eitest-A) + ":after") + +(ert-deftest eieio-test-method-order-list-5 () + (let ((eieio-test-method-order-list nil) + (ans (eitest-I (eitest-A nil)))) + (should (string= ans ":primary")))) + +;;; Multiple inheritance and the 'constructor' method. +;; +;; Constructor is a static method, so this is really testing +;; static method invocation and multiple inheritance. +;; +(defclass C-base1 () ()) +(defclass C-base2 () ()) +(defclass C (C-base1 C-base2) ()) + +;; Just use the obsolete name once, to make sure it also works. +(defmethod constructor :STATIC ((p C-base1) &rest args) + (eieio-test-method-store :STATIC 'C-base1) + (if (next-method-p) (call-next-method)) + ) + +(defmethod make-instance :STATIC ((p C-base2) &rest args) + (eieio-test-method-store :STATIC 'C-base2) + (if (next-method-p) (call-next-method)) + ) + +(cl-defmethod make-instance ((p (subclass C)) &rest args) + (eieio-test-method-store :STATIC 'C) + (cl-call-next-method) + ) + +(ert-deftest eieio-test-method-order-list-6 () + (let ((eieio-test-method-order-list nil) + (ans '( + (:STATIC C) + (:STATIC C-base1) + (:STATIC C-base2) + ))) + (C nil) + (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) + (eieio-test-match ans))) + +;;; Diamond Test +;; +;; For a diamond shaped inheritance structure, (call-next-method) can break. +;; As such, there are two possible orders. + +(defclass D-base0 () () :method-invocation-order :depth-first) +(defclass D-base1 (D-base0) () :method-invocation-order :depth-first) +(defclass D-base2 (D-base0) () :method-invocation-order :depth-first) +(defclass D (D-base1 D-base2) () :method-invocation-order :depth-first) + +(defmethod eitest-F ((p D)) + "D" + (eieio-test-method-store :PRIMARY 'D) + (call-next-method)) + +(defmethod eitest-F ((p D-base0)) + "D-base0" + (eieio-test-method-store :PRIMARY 'D-base0) + ;; This should have no next + ;; (when (next-method-p) (call-next-method)) + ) + +(defmethod eitest-F ((p D-base1)) + "D-base1" + (eieio-test-method-store :PRIMARY 'D-base1) + (call-next-method)) + +(defmethod eitest-F ((p D-base2)) + "D-base2" + (eieio-test-method-store :PRIMARY 'D-base2) + (when (next-method-p) + (call-next-method)) + ) + +(ert-deftest eieio-test-method-order-list-7 () + (let ((eieio-test-method-order-list nil) + (ans '( + (:PRIMARY D) + (:PRIMARY D-base1) + ;; (:PRIMARY D-base2) + (:PRIMARY D-base0) + ))) + (eitest-F (D nil)) + (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) + (eieio-test-match ans))) + +;;; Other invocation order + +(defclass E-base0 () () :method-invocation-order :breadth-first) +(defclass E-base1 (E-base0) () :method-invocation-order :breadth-first) +(defclass E-base2 (E-base0) () :method-invocation-order :breadth-first) +(defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first) + +(defmethod eitest-F ((p E)) + (eieio-test-method-store :PRIMARY 'E) + (call-next-method)) + +(defmethod eitest-F ((p E-base0)) + (eieio-test-method-store :PRIMARY 'E-base0) + ;; This should have no next + ;; (when (next-method-p) (call-next-method)) + ) + +(defmethod eitest-F ((p E-base1)) + (eieio-test-method-store :PRIMARY 'E-base1) + (call-next-method)) + +(defmethod eitest-F ((p E-base2)) + (eieio-test-method-store :PRIMARY 'E-base2) + (when (next-method-p) + (call-next-method)) + ) + +(ert-deftest eieio-test-method-order-list-8 () + (let ((eieio-test-method-order-list nil) + (ans '( + (:PRIMARY E) + (:PRIMARY E-base1) + (:PRIMARY E-base2) + (:PRIMARY E-base0) + ))) + (eitest-F (E nil)) + (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list)) + (eieio-test-match ans))) + +;;; Jan's methodinvoke order w/ multiple inheritance and :after methods. +;; +(defclass eitest-Ja () + ()) + +(defmethod initialize-instance :after ((this eitest-Ja) &rest slots) + ;(message "+Ja") + ;; FIXME: Using next-method-p in an after-method is invalid! + (when (next-method-p) + (call-next-method)) + ;(message "-Ja") + ) + +(defclass eitest-Jb () + ()) + +(defmethod initialize-instance :after ((this eitest-Jb) &rest slots) + ;(message "+Jb") + ;; FIXME: Using next-method-p in an after-method is invalid! + (when (next-method-p) + (call-next-method)) + ;(message "-Jb") + ) + +(defclass eitest-Jc (eitest-Jb) + ()) + +(defclass eitest-Jd (eitest-Jc eitest-Ja) + ()) + +(defmethod initialize-instance ((this eitest-Jd) &rest slots) + ;(message "+Jd") + (when (next-method-p) + (call-next-method)) + ;(message "-Jd") + ) + +(ert-deftest eieio-test-method-order-list-9 () + (should (eitest-Jd "test"))) + +;;; call-next-method with replacement arguments across a simple class hierarchy. +;; + +(defclass CNM-0 () + ()) + +(defclass CNM-1-1 (CNM-0) + ()) + +(defclass CNM-1-2 (CNM-0) + ()) + +(defclass CNM-2 (CNM-1-1 CNM-1-2) + ()) + +(defmethod CNM-M ((this CNM-0) args) + (push (cons 'CNM-0 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-0 args)))) + +(defmethod CNM-M ((this CNM-1-1) args) + (push (cons 'CNM-1-1 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-1-1 args)))) + +(defmethod CNM-M ((this CNM-1-2) args) + (push (cons 'CNM-1-2 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method))) + +(defmethod CNM-M ((this CNM-2) args) + (push (cons 'CNM-2 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-2 args)))) + +(ert-deftest eieio-test-method-order-list-10 () + (let ((eieio-test-call-next-method-arguments nil)) + (CNM-M (CNM-2 "") '(INIT)) + (should (equal (eieio-test-arguments-for 'CNM-0) + '(CNM-1-1 CNM-2 INIT))) + (should (equal (eieio-test-arguments-for 'CNM-1-1) + '(CNM-2 INIT))) + (should (equal (eieio-test-arguments-for 'CNM-1-2) + '(CNM-1-1 CNM-2 INIT))) + (should (equal (eieio-test-arguments-for 'CNM-2) + '(INIT))))) + +;;; Check cl-generic integration. + +(cl-defgeneric eieio-test--1 (x y)) + +(ert-deftest eieio-test-cl-generic-1 () + (cl-defgeneric eieio-test--1 (x y)) + (cl-defmethod eieio-test--1 (x y) (list x y)) + (cl-defmethod eieio-test--1 ((_x CNM-0) y) + (cons "CNM-0" (cl-call-next-method 7 y))) + (cl-defmethod eieio-test--1 ((_x CNM-1-1) _y) + (cons "CNM-1-1" (cl-call-next-method))) + (cl-defmethod eieio-test--1 ((_x CNM-1-2) _y) + (cons "CNM-1-2" (cl-call-next-method))) + (cl-defmethod eieio-test--1 ((_x (subclass CNM-1-2)) _y) + (cons "subclass CNM-1-2" (cl-call-next-method))) + (should (equal (eieio-test--1 4 5) '(4 5))) + (should (equal (eieio-test--1 (make-instance 'CNM-0) 5) + '("CNM-0" 7 5))) + (should (equal (eieio-test--1 (make-instance 'CNM-2) 5) + '("CNM-1-1" "CNM-1-2" "CNM-0" 7 5))) + (should (equal (eieio-test--1 'CNM-2 6) '("subclass CNM-1-2" CNM-2 6)))) diff --cc test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el index 2f8d65e512e,00000000000..da4cc5f51f3 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el @@@ -1,219 -1,0 +1,219 @@@ +;;; eieio-persist.el --- Tests for eieio-persistent class + - ;; Copyright (C) 2011-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2011-2017 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; The eieio-persistent base-class provides a vital service, that +;; could be used to accidentally load in malicious code. As such, +;; something as simple as calling eval on the generated code can't be +;; used. These tests exercises various flavors of data that might be +;; in a persistent object, and tries to save/load them. + +;;; Code: +(require 'eieio) +(require 'eieio-base) +(require 'ert) + +(defun eieio--attribute-to-initarg (class attribute) + "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag. +This is usually a symbol that starts with `:'." + (let ((tuple (rassoc attribute (eieio--class-initarg-tuples class)))) + (if tuple + (car tuple) + nil))) + +(defun persist-test-save-and-compare (original) + "Compare the object ORIGINAL against the one read fromdisk." + + (eieio-persistent-save original) + + (let* ((file (oref original file)) + (class (eieio-object-class original)) + (fromdisk (eieio-persistent-read file class)) + (cv (cl--find-class class)) + (slots (eieio--class-slots cv)) + ) + (unless (object-of-class-p fromdisk class) + (error "Persistent class %S != original class %S" + (eieio-object-class fromdisk) + class)) + + (dotimes (i (length slots)) + (let* ((slot (aref slots i)) + (oneslot (cl--slot-descriptor-name slot)) + (origvalue (eieio-oref original oneslot)) + (fromdiskvalue (eieio-oref fromdisk oneslot)) + (initarg-p (eieio--attribute-to-initarg + (cl--find-class class) oneslot)) + ) + + (if initarg-p + (unless (equal origvalue fromdiskvalue) + (error "Slot %S Original Val %S != Persistent Val %S" + oneslot origvalue fromdiskvalue)) + ;; Else !initarg-p + (unless (equal (cl--slot-descriptor-initform slot) fromdiskvalue) + (error "Slot %S Persistent Val %S != Default Value %S" + oneslot fromdiskvalue (cl--slot-descriptor-initform slot)))) + )))) + +;;; Simple Case +;; +;; Simplest case is a mix of slots with and without initargs. + +(defclass persist-simple (eieio-persistent) + ((slot1 :initarg :slot1 + :type symbol + :initform moose) + (slot2 :initarg :slot2 + :initform "foo") + (slot3 :initform 2)) + "A Persistent object with two initializable slots, and one not.") + +(ert-deftest eieio-test-persist-simple-1 () + (let ((persist-simple-1 + (persist-simple "simple 1" :slot1 'goose :slot2 "testing" + :file (concat default-directory "test-ps1.pt")))) + (should persist-simple-1) + + ;; When the slot w/out an initarg has not been changed + (persist-test-save-and-compare persist-simple-1) + + ;; When the slot w/out an initarg HAS been changed + (oset persist-simple-1 slot3 3) + (persist-test-save-and-compare persist-simple-1) + (delete-file (oref persist-simple-1 file)))) + +;;; Slot Writers +;; +;; Replica of the test in eieio-tests.el - + +(defclass persist-:printer (eieio-persistent) + ((slot1 :initarg :slot1 + :initform 'moose + :printer PO-slot1-printer) + (slot2 :initarg :slot2 + :initform "foo")) + "A Persistent object with two initializable slots.") + +(defun PO-slot1-printer (slotvalue) + "Print the slot value SLOTVALUE to stdout. +Assume SLOTVALUE is a symbol of some sort." + (princ "'") + (princ (symbol-name slotvalue)) + (princ " ;; RAN PRINTER") + nil) + +(ert-deftest eieio-test-persist-printer () + (let ((persist-:printer-1 + (persist-:printer "persist" :slot1 'goose :slot2 "testing" + :file (concat default-directory "test-ps2.pt")))) + (should persist-:printer-1) + (persist-test-save-and-compare persist-:printer-1) + + (let* ((find-file-hook nil) + (tbuff (find-file-noselect "test-ps2.pt")) + ) + (condition-case nil + (unwind-protect + (with-current-buffer tbuff + (goto-char (point-min)) + (re-search-forward "RAN PRINTER")) + (kill-buffer tbuff)) + (error "persist-:printer-1's Slot1 printer function didn't work."))) + (delete-file (oref persist-:printer-1 file)))) + +;;; Slot with Object +;; +;; A slot that contains another object that isn't persistent +(defclass persist-not-persistent () + ((slot1 :initarg :slot1 + :initform 1) + (slot2 :initform 2)) + "Class for testing persistent saving of an object that isn't +persistent. This class is instead used as a slot value in a +persistent class.") + +(defclass persistent-with-objs-slot (eieio-persistent) + ((pnp :initarg :pnp + :type (or null persist-not-persistent) + :initform nil)) + "Class for testing the saving of slots with objects in them.") + +(ert-deftest eieio-test-non-persistent-as-slot () + (let ((persist-wos + (persistent-with-objs-slot + "persist wos 1" + :pnp (persist-not-persistent "pnp 1" :slot1 3) + :file (concat default-directory "test-ps3.pt")))) + + (persist-test-save-and-compare persist-wos) + (delete-file (oref persist-wos file)))) + +;;; Slot with Object child of :type +;; +;; A slot that contains another object that isn't persistent +(defclass persist-not-persistent-subclass (persist-not-persistent) + ((slot3 :initarg :slot1 + :initform 1) + (slot4 :initform 2)) + "Class for testing persistent saving of an object subclass that isn't +persistent. This class is instead used as a slot value in a +persistent class.") + +(defclass persistent-with-objs-slot-subs (eieio-persistent) + ((pnp :initarg :pnp + :type (or null persist-not-persistent) + :initform nil)) + "Class for testing the saving of slots with objects in them.") + +(ert-deftest eieio-test-non-persistent-as-slot-child () + (let ((persist-woss + (persistent-with-objs-slot-subs + "persist woss 1" + :pnp (persist-not-persistent-subclass "pnps 1" :slot1 3) + :file (concat default-directory "test-ps4.pt")))) + + (persist-test-save-and-compare persist-woss) + (delete-file (oref persist-woss file)))) + +;;; Slot with a list of Objects +;; +;; A slot that contains another object that isn't persistent +(defclass persistent-with-objs-list-slot (eieio-persistent) + ((pnp :initarg :pnp + :type (list-of persist-not-persistent) + :initform nil)) + "Class for testing the saving of slots with objects in them.") + +(ert-deftest eieio-test-slot-with-list-of-objects () + (let ((persist-wols + (persistent-with-objs-list-slot + "persist wols 1" + :pnp (list (persist-not-persistent "pnp 1" :slot1 3) + (persist-not-persistent "pnp 2" :slot1 4) + (persist-not-persistent "pnp 3" :slot1 5)) + :file (concat default-directory "test-ps5.pt")))) + + (persist-test-save-and-compare persist-wols) + (delete-file (oref persist-wols file)))) + +;;; eieio-test-persist.el ends here diff --cc test/lisp/emacs-lisp/eieio-tests/eieio-tests.el index 9665beb490e,00000000000..db601abbd0a mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@@ -1,906 -1,0 +1,906 @@@ +;;; eieio-tests.el -- eieio tests routines + - ;; Copyright (C) 1999-2003, 2005-2010, 2012-2016 Free Software ++;; Copyright (C) 1999-2003, 2005-2010, 2012-2017 Free Software +;; Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Test the various features of EIEIO. + +(require 'ert) +(require 'eieio) +(require 'eieio-base) +(require 'eieio-opt) + +(eval-when-compile (require 'cl-lib)) + +;;; Code: +;; Set up some test classes +(defclass class-a () + ((water :initarg :water + :initform h20 + :type symbol + :documentation "Detail about water.") + (classslot :initform penguin + :type symbol + :documentation "A class allocated slot." + :allocation :class) + (test-tag :initform nil + :documentation "Used to make sure methods are called.") + (self :initform nil + :type (or null class-a) + :documentation "Test self referencing types.") + ) + "Class A") + +(defclass class-b () + ((land :initform "Sc" + :type string + :documentation "Detail about land.")) + "Class B") + +(defclass class-ab (class-a class-b) + ((amphibian :initform "frog" + :documentation "Detail about amphibian on land and water.")) + "Class A and B combined.") + +(defclass class-c () + ((slot-1 :initarg :moose + :initform moose + :type symbol + :allocation :instance + :documentation "First slot testing slot arguments." + :custom symbol + :label "Wild Animal" + :group borg + :protection :public) + (slot-2 :initarg :penguin + :initform "penguin" + :type string + :allocation :instance + :documentation "Second slot testing slot arguments." + :custom string + :label "Wild bird" + :group vorlon + :accessor get-slot-2 + :protection :private) + (slot-3 :initarg :emu + :initform emu + :type symbol + :allocation :class + :documentation "Third slot test class allocated accessor" + :custom symbol + :label "Fuzz" + :group tokra + :accessor get-slot-3 + :protection :private) + ) + (:custom-groups (foo)) + "A class for testing slot arguments." + ) + +(defclass class-subc (class-c) + ((slot-1 ;; :initform moose - don't override this + ) + (slot-2 :initform "linux" ;; Do override this one + :protection :private + )) + "A class for testing slot arguments.") + +;;; Defining a class with a slot tag error +;; +;; Temporarily disable this test because of macro expansion changes in +;; current Emacs trunk. It can be re-enabled when we have moved +;; `eieio-defclass' into the `defclass' macro and the +;; `eval-and-compile' there is removed. + +;; (let ((eieio-error-unsupported-class-tags t)) +;; (condition-case nil +;; (progn +;; (defclass class-error () +;; ((error-slot :initarg :error-slot +;; :badslottag 1)) +;; "A class with a bad slot tag.") +;; (error "No error was thrown for badslottag")) +;; (invalid-slot-type nil))) + +;; (let ((eieio-error-unsupported-class-tags nil)) +;; (condition-case nil +;; (progn +;; (defclass class-error () +;; ((error-slot :initarg :error-slot +;; :badslottag 1)) +;; "A class with a bad slot tag.")) +;; (invalid-slot-type +;; (error "invalid-slot-type thrown when eieio-error-unsupported-class-tags is nil") +;; ))) + +(ert-deftest eieio-test-01-mix-alloc-initarg () + ;; Only run this test if the message framework thingy works. + (when (and (message "foo") (string= "foo" (current-message))) + + ;; Defining this class should generate a warning(!) message that + ;; you should not mix :initarg with class allocated slots. + (defclass class-alloc-initarg () + ((throwwarning :initarg :throwwarning + :allocation :class)) + "Throw a warning mixing allocation class and an initarg.") + + ;; Check that message is there + (should (current-message)) + (should (string-match "Class allocated slots do not need :initarg" + (current-message))))) + +(defclass abstract-class () + ((some-slot :initarg :some-slot + :initform nil + :documentation "A slot.")) + :documentation "An abstract class." + :abstract t) + +(ert-deftest eieio-test-02-abstract-class () + ;; Abstract classes cannot be instantiated, so this should throw an + ;; error + (should-error (abstract-class))) + +(defgeneric generic1 () "First generic function") + +(ert-deftest eieio-test-03-generics () + (defun anormalfunction () "A plain function for error testing." nil) + (should-error + (progn + (defgeneric anormalfunction () + "Attempt to turn it into a generic."))) + + ;; Check that generic-p works + (should (generic-p 'generic1)) + + (defmethod generic1 ((c class-a)) + "Method on generic1." + 'monkey) + + (defmethod generic1 (not-an-object) + "Method generic1 that can take a non-object." + not-an-object) + + (let ((ans-obj (generic1 (class-a))) + (ans-num (generic1 666))) + (should (eq ans-obj 'monkey)) + (should (eq ans-num 666)))) + +(defclass static-method-class () + ((some-slot :initform nil + :allocation :class + :documentation "A slot.")) + :documentation "A class used for testing static methods.") + +(defmethod static-method-class-method :STATIC ((c static-method-class) value) + "Test static methods. +Argument C is the class bound to this static method." + (if (eieio-object-p c) (setq c (eieio-object-class c))) + (oset-default c some-slot value)) + +(ert-deftest eieio-test-04-static-method () + ;; Call static method on a class and see if it worked + (static-method-class-method 'static-method-class 'class) + (should (eq (oref-default 'static-method-class some-slot) 'class)) + (static-method-class-method (static-method-class) 'object) + (should (eq (oref-default 'static-method-class some-slot) 'object))) + +(ert-deftest eieio-test-05-static-method-2 () + (defclass static-method-class-2 (static-method-class) + () + "A second class after the previous for static methods.") + + (defmethod static-method-class-method :STATIC ((c static-method-class-2) value) + "Test static methods. +Argument C is the class bound to this static method." + (if (eieio-object-p c) (setq c (eieio-object-class c))) + (oset-default c some-slot (intern (concat "moose-" (symbol-name value))))) + + (static-method-class-method 'static-method-class-2 'class) + (should (eq (oref-default 'static-method-class-2 some-slot) 'moose-class)) + (static-method-class-method (static-method-class-2) 'object) + (should (eq (oref-default 'static-method-class-2 some-slot) 'moose-object))) + + +;;; Perform method testing +;; + +;;; Multiple Inheritance, and method signal testing +;; +(defvar eitest-ab nil) +(defvar eitest-a nil) +(defvar eitest-b nil) +(ert-deftest eieio-test-06-allocate-objects () + ;; allocate an object to use + (should (setq eitest-ab (class-ab))) + (should (setq eitest-a (class-a))) + (should (setq eitest-b (class-b)))) + +(ert-deftest eieio-test-07-make-instance () + (should (make-instance 'class-ab)) + (should (make-instance 'class-a :water 'cho)) + (should (make-instance 'class-b))) + +(defmethod class-cn ((a class-a)) + "Try calling `call-next-method' when there isn't one. +Argument A is object of type symbol `class-a'." + (call-next-method)) + +(defmethod no-next-method ((a class-a) &rest args) + "Override signal throwing for variable `class-a'. +Argument A is the object of class variable `class-a'." + 'moose) + +(ert-deftest eieio-test-08-call-next-method () + ;; Play with call-next-method + (should (eq (class-cn eitest-ab) 'moose))) + +(defmethod no-applicable-method ((b class-b) method &rest args) + "No need. +Argument B is for booger. +METHOD is the method that was attempting to be called." + 'moose) + +(ert-deftest eieio-test-09-no-applicable-method () + ;; Non-existing methods. + (should (eq (class-cn eitest-b) 'moose))) + +(defmethod class-fun ((a class-a)) + "Fun with class A." + 'moose) + +(defmethod class-fun ((b class-b)) + "Fun with class B." + (error "Class B fun should not be called") + ) + +(defmethod class-fun-foo ((b class-b)) + "Foo Fun with class B." + 'moose) + +(defmethod class-fun2 ((a class-a)) + "More fun with class A." + 'moose) + +(defmethod class-fun2 ((b class-b)) + "More fun with class B." + (error "Class B fun2 should not be called") + ) + +(defmethod class-fun2 ((ab class-ab)) + "More fun with class AB." + (call-next-method)) + +;; How about if B is the only slot? +(defmethod class-fun3 ((b class-b)) + "Even More fun with class B." + 'moose) + +(defmethod class-fun3 ((ab class-ab)) + "Even More fun with class AB." + (call-next-method)) + +(ert-deftest eieio-test-10-multiple-inheritance () + ;; play with methods and mi + (should (eq (class-fun eitest-ab) 'moose)) + (should (eq (class-fun-foo eitest-ab) 'moose)) + ;; Play with next-method and mi + (should (eq (class-fun2 eitest-ab) 'moose)) + (should (eq (class-fun3 eitest-ab) 'moose))) + +(ert-deftest eieio-test-11-self () + ;; Try the self referencing test + (should (oset eitest-a self eitest-a)) + (should (oset eitest-ab self eitest-ab))) + + +(defvar class-fun-value-seq '()) +(defmethod class-fun-value :BEFORE ((a class-a)) + "Return `before', and push `before' in `class-fun-value-seq'." + (push 'before class-fun-value-seq) + 'before) + +(defmethod class-fun-value :PRIMARY ((a class-a)) + "Return `primary', and push `primary' in `class-fun-value-seq'." + (push 'primary class-fun-value-seq) + 'primary) + +(defmethod class-fun-value :AFTER ((a class-a)) + "Return `after', and push `after' in `class-fun-value-seq'." + (push 'after class-fun-value-seq) + 'after) + +(ert-deftest eieio-test-12-generic-function-call () + ;; Test value of a generic function call + ;; + (let* ((class-fun-value-seq nil) + (value (class-fun-value eitest-a))) + ;; Test if generic function call returns the primary method's value + (should (eq value 'primary)) + ;; Make sure :before and :after methods were run + (should (equal class-fun-value-seq '(after primary before))))) + +;;; Test initialization methods +;; + +(ert-deftest eieio-test-13-init-methods () + (defmethod initialize-instance ((a class-a) &rest slots) + "Initialize the slots of class-a." + (call-next-method) + (if (/= (oref a test-tag) 1) + (error "shared-initialize test failed.")) + (oset a test-tag 2)) + + (defmethod shared-initialize ((a class-a) &rest slots) + "Shared initialize method for class-a." + (call-next-method) + (oset a test-tag 1)) + + (let ((ca (class-a))) + (should-not (/= (oref ca test-tag) 2)))) + + +;;; Perform slot testing +;; +(ert-deftest eieio-test-14-slots () + ;; Check slot existence + (should (oref eitest-ab water)) + (should (oref eitest-ab land)) + (should (oref eitest-ab amphibian))) + +(ert-deftest eieio-test-15-slot-missing () + + (defmethod slot-missing ((ab class-ab) &rest foo) + "If a slot in AB is unbound, return something cool. FOO." + 'moose) + + (should (eq (oref eitest-ab ooga-booga) 'moose)) + (should-error (oref eitest-a ooga-booga) :type 'invalid-slot-name)) + +(ert-deftest eieio-test-16-slot-makeunbound () + (slot-makeunbound eitest-a 'water) + ;; Should now be unbound + (should-not (slot-boundp eitest-a 'water)) + ;; But should still exist + (should (slot-exists-p eitest-a 'water)) + (should-not (slot-exists-p eitest-a 'moose)) + ;; oref of unbound slot must fail + (should-error (oref eitest-a water) :type 'unbound-slot)) + +(defvar eitest-vsca nil) +(defvar eitest-vscb nil) +(defclass virtual-slot-class () + ((base-value :initarg :base-value)) + "Class has real slot :base-value and simulated slot :derived-value.") +(defmethod slot-missing ((vsc virtual-slot-class) + slot-name operation &optional new-value) + "Simulate virtual slot derived-value." + (cond + ((or (eq slot-name :derived-value) + (eq slot-name 'derived-value)) + (with-slots (base-value) vsc + (if (eq operation 'oref) + (+ base-value 1) + (setq base-value (- new-value 1))))) + (t (call-next-method)))) + +(ert-deftest eieio-test-17-virtual-slot () + (setq eitest-vsca (virtual-slot-class :base-value 1)) + ;; Check slot values + (should (= (oref eitest-vsca base-value) 1)) + (should (= (oref eitest-vsca :derived-value) 2)) + + (oset eitest-vsca derived-value 3) + (should (= (oref eitest-vsca base-value) 2)) + (should (= (oref eitest-vsca :derived-value) 3)) + + (oset eitest-vsca base-value 3) + (should (= (oref eitest-vsca base-value) 3)) + (should (= (oref eitest-vsca :derived-value) 4)) + + ;; should also be possible to initialize instance using virtual slot + + (setq eitest-vscb (virtual-slot-class :derived-value 5)) + (should (= (oref eitest-vscb base-value) 4)) + (should (= (oref eitest-vscb :derived-value) 5))) + +(ert-deftest eieio-test-18-slot-unbound () + + (defmethod slot-unbound ((a class-a) &rest foo) + "If a slot in A is unbound, ignore FOO." + 'moose) + + (should (eq (oref eitest-a water) 'moose)) + + ;; Check if oset of unbound works + (oset eitest-a water 'moose) + (should (eq (oref eitest-a water) 'moose)) + + ;; oref/oref-default comparison + (should-not (eq (oref eitest-a water) (oref-default eitest-a water))) + + ;; oset-default -> oref/oref-default comparison + (oset-default (eieio-object-class eitest-a) water 'moose) + (should (eq (oref eitest-a water) (oref-default eitest-a water))) + + ;; After setting 'water to 'moose, make sure a new object has + ;; the right stuff. + (oset-default (eieio-object-class eitest-a) water 'penguin) + (should (eq (oref (class-a) water) 'penguin)) + + ;; Revert the above + (defmethod slot-unbound ((a class-a) &rest foo) + "If a slot in A is unbound, ignore FOO." + ;; Disable the old slot-unbound so we can run this test + ;; more than once + (call-next-method))) + +(ert-deftest eieio-test-19-slot-type-checking () + ;; Slot type checking + ;; We should not be able to set a string here + (should-error (oset eitest-ab water "a string, not a symbol") :type 'invalid-slot-type) + (should-error (oset eitest-ab classslot "a string, not a symbol") :type 'invalid-slot-type) + (should-error (class-a :water "a string not a symbol") :type 'invalid-slot-type)) + +(ert-deftest eieio-test-20-class-allocated-slots () + ;; Test out class allocated slots + (defvar eitest-aa nil) + (setq eitest-aa (class-a)) + + ;; Make sure class slots do not track between objects + (let ((newval 'moose)) + (oset eitest-aa classslot newval) + (should (eq (oref eitest-a classslot) newval)) + (should (eq (oref eitest-aa classslot) newval))) + + ;; Slot should be bound + (should (slot-boundp eitest-a 'classslot)) + (should (slot-boundp 'class-a 'classslot)) + + (slot-makeunbound eitest-a 'classslot) + + (should-not (slot-boundp eitest-a 'classslot)) + (should-not (slot-boundp 'class-a 'classslot))) + + +(defvar eieio-test-permuting-value nil) +(defvar eitest-pvinit nil) +(eval-and-compile + (setq eieio-test-permuting-value 1)) + +(defclass inittest nil + ((staticval :initform 1) + (symval :initform eieio-test-permuting-value) + (evalval :initform (symbol-value 'eieio-test-permuting-value)) + (evalnow :initform (symbol-value 'eieio-test-permuting-value) + :allocation :class) + ) + "Test initforms that eval.") + +(ert-deftest eieio-test-21-eval-at-construction-time () + ;; initforms that need to be evalled at construction time. + (setq eieio-test-permuting-value 2) + (setq eitest-pvinit (inittest)) + + (should (eq (oref eitest-pvinit staticval) 1)) + (should (eq (oref eitest-pvinit symval) 'eieio-test-permuting-value)) + (should (eq (oref eitest-pvinit evalval) 2)) + (should (eq (oref eitest-pvinit evalnow) 1))) + +(defvar eitest-tests nil) + +(ert-deftest eieio-test-22-init-forms-dont-match-runnable () + ;; Init forms with types that don't match the runnable. + (defclass eitest-subordinate nil + ((text :initform "" :type string)) + "Test class that will be a calculated value.") + + (defclass eitest-superior nil + ((sub :initform (eitest-subordinate) + :type eitest-subordinate)) + "A class with an initform that creates a class.") + + (should (setq eitest-tests (eitest-superior))) + + (should-error + (eval + '(defclass broken-init nil + ((broken :initform 1 + :type string)) + "This class should break.")) + :type 'invalid-slot-type)) + +(ert-deftest eieio-test-23-inheritance-check () + (should (child-of-class-p 'class-ab 'class-a)) + (should (child-of-class-p 'class-ab 'class-b)) + (should (object-of-class-p eitest-a 'class-a)) + (should (object-of-class-p eitest-ab 'class-a)) + (should (object-of-class-p eitest-ab 'class-b)) + (should (object-of-class-p eitest-ab 'class-ab)) + (should (eq (eieio-class-parents 'class-a) nil)) + (should (equal (eieio-class-parents 'class-ab) + (mapcar #'find-class '(class-a class-b)))) + (should (same-class-p eitest-a 'class-a)) + (should (class-a-p eitest-a)) + (should (not (class-a-p eitest-ab))) + (should (cl-typep eitest-a 'class-a)) + (should (cl-typep eitest-ab 'class-a)) + (should (not (class-a-p "foo"))) + (should (not (cl-typep "foo" 'class-a)))) + +(ert-deftest eieio-test-24-object-predicates () + (let ((listooa (list (class-ab) (class-a))) + (listoob (list (class-ab) (class-b)))) + (should (cl-typep listooa '(list-of class-a))) + (should (cl-typep listoob '(list-of class-b))) + (should-not (cl-typep listooa '(list-of class-b))) + (should-not (cl-typep listoob '(list-of class-a))))) + +(defvar eitest-t1 nil) +(ert-deftest eieio-test-25-slot-tests () + (setq eitest-t1 (class-c)) + ;; Slot initialization + (should (eq (oref eitest-t1 slot-1) 'moose)) + ;; Accessing via the initarg name is deprecated! + ;; (should (eq (oref eitest-t1 :moose) 'moose)) + ;; Don't pass reference of private slot + ;;PRIVATE (should-error (oref eitest-t1 slot-2) :type 'invalid-slot-name) + ;; Check private slot accessor + (should (string= (get-slot-2 eitest-t1) "penguin")) + ;; Pass string instead of symbol + (should-error (class-c :moose "not a symbol") :type 'invalid-slot-type) + (should (eq (get-slot-3 eitest-t1) 'emu)) + (should (eq (get-slot-3 'class-c) 'emu)) + ;; Check setf + (setf (get-slot-3 eitest-t1) 'setf-emu) + (should (eq (get-slot-3 eitest-t1) 'setf-emu)) + ;; Roll back + (setf (get-slot-3 eitest-t1) 'emu)) + +(defvar eitest-t2 nil) +(ert-deftest eieio-test-26-default-inheritance () + ;; See previous test, nor for subclass + (setq eitest-t2 (class-subc)) + (should (eq (oref eitest-t2 slot-1) 'moose)) + ;; Accessing via the initarg name is deprecated! + ;;(should (eq (oref eitest-t2 :moose) 'moose)) + (should (string= (get-slot-2 eitest-t2) "linux")) + ;;PRIVATE (should-error (oref eitest-t2 slot-2) :type 'invalid-slot-name) + (should (string= (get-slot-2 eitest-t2) "linux")) + (should-error (class-subc :moose "not a symbol") :type 'invalid-slot-type)) + +;;(ert-deftest eieio-test-27-inherited-new-value () + ;;; HACK ALERT: The new value of a class slot is inherited by the + ;; subclass! This is probably a bug. We should either share the slot + ;; so sets on the baseclass change the subclass, or we should inherit + ;; the original value. +;; (should (eq (get-slot-3 eitest-t2) 'emu)) +;; (should (eq (get-slot-3 class-subc) 'emu)) +;; (setf (get-slot-3 eitest-t2) 'setf-emu) +;; (should (eq (get-slot-3 eitest-t2) 'setf-emu))) + +;; Slot protection +(defclass prot-0 () + () + "Protection testing baseclass.") + +(defmethod prot0-slot-2 ((s2 prot-0)) + "Try to access slot-2 from this class which doesn't have it. +The object S2 passed in will be of class prot-1, which does have +the slot. This could be allowed, and currently is in EIEIO. +Needed by the eieio persistent base class." + (oref s2 slot-2)) + +(defclass prot-1 (prot-0) + ((slot-1 :initarg :slot-1 + :initform nil + :protection :public) + (slot-2 :initarg :slot-2 + :initform nil + :protection :protected) + (slot-3 :initarg :slot-3 + :initform nil + :protection :private)) + "A class for testing the :protection option.") + +(defclass prot-2 (prot-1) + nil + "A class for testing the :protection option.") + +(defmethod prot1-slot-2 ((s2 prot-1)) + "Try to access slot-2 in S2." + (oref s2 slot-2)) + +(defmethod prot1-slot-2 ((s2 prot-2)) + "Try to access slot-2 in S2." + (oref s2 slot-2)) + +(defmethod prot1-slot-3-only ((s2 prot-1)) + "Try to access slot-3 in S2. +Do not override for `prot-2'." + (oref s2 slot-3)) + +(defmethod prot1-slot-3 ((s2 prot-1)) + "Try to access slot-3 in S2." + (oref s2 slot-3)) + +(defmethod prot1-slot-3 ((s2 prot-2)) + "Try to access slot-3 in S2." + (oref s2 slot-3)) + +(defvar eitest-p1 nil) +(defvar eitest-p2 nil) +(ert-deftest eieio-test-28-slot-protection () + (setq eitest-p1 (prot-1)) + (setq eitest-p2 (prot-2)) + ;; Access public slots + (oref eitest-p1 slot-1) + (oref eitest-p2 slot-1) + ;; Accessing protected slot out of context used to fail, but we dropped this + ;; feature, since it was underused and no one noticed that the check was + ;; incorrect (much too loose). + ;;PROTECTED (should-error (oref eitest-p1 slot-2) :type 'invalid-slot-name) + ;; Access protected slot in method + (prot1-slot-2 eitest-p1) + ;; Protected slot in subclass method + (prot1-slot-2 eitest-p2) + ;; Protected slot from parent class method + (prot0-slot-2 eitest-p1) + ;; Accessing private slot out of context used to fail, but we dropped this + ;; feature, since it was not used. + ;;PRIVATE (should-error (oref eitest-p1 slot-3) :type 'invalid-slot-name) + ;; Access private slot in method + (prot1-slot-3 eitest-p1) + ;; Access private slot in subclass method must fail + ;;PRIVATE (should-error (prot1-slot-3 eitest-p2) :type 'invalid-slot-name) + ;; Access private slot by same class + (prot1-slot-3-only eitest-p1) + ;; Access private slot by subclass in sameclass method + (prot1-slot-3-only eitest-p2)) + +;;; eieio-instance-inheritor +;; Test to make sure this works. +(defclass II (eieio-instance-inheritor) + ((slot1 :initform 1) + (slot2) + (slot3)) + "Instance Inheritor test class.") + +(defvar eitest-II1 nil) +(defvar eitest-II2 nil) +(defvar eitest-II3 nil) +(ert-deftest eieio-test-29-instance-inheritor () + (setq eitest-II1 (II "II Test.")) + (oset eitest-II1 slot2 'cat) + (setq eitest-II2 (clone eitest-II1 "eitest-II2 Test.")) + (oset eitest-II2 slot1 'moose) + (setq eitest-II3 (clone eitest-II2 "eitest-II3 Test.")) + (oset eitest-II3 slot3 'penguin) + + ;; Test level 1 inheritance + (should (eq (oref eitest-II3 slot1) 'moose)) + ;; Test level 2 inheritance + (should (eq (oref eitest-II3 slot2) 'cat)) + ;; Test level 0 inheritance + (should (eq (oref eitest-II3 slot3) 'penguin))) + +(defclass slotattr-base () + ((initform :initform init) + (type :type list) + (initarg :initarg :initarg) + (protection :protection :private) + (custom :custom (repeat string) + :label "Custom Strings" + :group moose) + (docstring :documentation + "Replace the doc-string for this property.") + (printer :printer printer1) + ) + "Baseclass we will attempt to subclass. +Subclasses to override slot attributes.") + +(defclass slotattr-ok (slotattr-base) + ((initform :initform no-init) + (initarg :initarg :initblarg) + (custom :custom string + :label "One String" + :group cow) + (docstring :documentation + "A better doc string for this class.") + (printer :printer printer2) + ) + "This class should allow overriding of various slot attributes.") + + +(ert-deftest eieio-test-30-slot-attribute-override () + ;; Subclass should not override :protection slot attribute + ;;PROTECTION is gone. + ;;(should-error + ;; (eval + ;; '(defclass slotattr-fail (slotattr-base) + ;; ((protection :protection :public) + ;; ) + ;; "This class should throw an error."))) + + ;; Subclass should not override :type slot attribute + (should-error + (eval + '(defclass slotattr-fail (slotattr-base) + ((type :type string) + ) + "This class should throw an error."))) + + ;; Initform should override instance allocation + (let ((obj (slotattr-ok))) + (should (eq (oref obj initform) 'no-init)))) + +(defclass slotattr-class-base () + ((initform :allocation :class + :initform init) + (type :allocation :class + :type list) + (initarg :allocation :class + :initarg :initarg) + (protection :allocation :class + :protection :private) + (custom :allocation :class + :custom (repeat string) + :label "Custom Strings" + :group moose) + (docstring :allocation :class + :documentation + "Replace the doc-string for this property.") + ) + "Baseclass we will attempt to subclass. +Subclasses to override slot attributes.") + +(defclass slotattr-class-ok (slotattr-class-base) + ((initform :initform no-init) + (initarg :initarg :initblarg) + (custom :custom string + :label "One String" + :group cow) + (docstring :documentation + "A better doc string for this class.") + ) + "This class should allow overriding of various slot attributes.") + + +(ert-deftest eieio-test-31-slot-attribute-override-class-allocation () + ;; Same as test-30, but with class allocation + ;;PROTECTION is gone. + ;;(should-error + ;; (eval + ;; '(defclass slotattr-fail (slotattr-class-base) + ;; ((protection :protection :public) + ;; ) + ;; "This class should throw an error."))) + (should-error + (eval + '(defclass slotattr-fail (slotattr-class-base) + ((type :type string) + ) + "This class should throw an error."))) + (should (eq (oref-default 'slotattr-class-ok initform) 'no-init))) + +(ert-deftest eieio-test-32-slot-attribute-override-2 () + (let* ((cv (cl--find-class 'slotattr-ok)) + (slots (eieio--class-slots cv)) + (args (eieio--class-initarg-tuples cv))) + ;; :initarg should override for subclass + (should (assoc :initblarg args)) + + (dotimes (i (length slots)) + (let* ((slot (aref slots i)) + (props (cl--slot-descriptor-props slot))) + (cond + ((eq (cl--slot-descriptor-name slot) 'custom) + ;; Custom slot attributes must override + (should (eq (alist-get :custom props) 'string)) + ;; Custom label slot attribute must override + (should (string= (alist-get :label props) "One String")) + (let ((grp (alist-get :group props))) + ;; Custom group slot attribute must combine + (should (and (memq 'moose grp) (memq 'cow grp))))) + (t nil)))))) + +(defvar eitest-CLONETEST1 nil) +(defvar eitest-CLONETEST2 nil) + +(ert-deftest eieio-test-32-test-clone-boring-objects () + ;; A simple make instance with EIEIO extension + (should (setq eitest-CLONETEST1 (make-instance 'class-a))) + (should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1))) + + ;; CLOS form of make-instance + (should (setq eitest-CLONETEST1 (make-instance 'class-a))) + (should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1)))) + +(defclass IT (eieio-instance-tracker) + ((tracking-symbol :initform IT-list) + (slot1 :initform 'die)) + "Instance Tracker test object.") + +(ert-deftest eieio-test-33-instance-tracker () + (let (IT-list IT1) + (should (setq IT1 (IT))) + ;; The instance tracker must find this + (should (eieio-instance-tracker-find 'die 'slot1 'IT-list)) + ;; Test deletion + (delete-instance IT1) + (should-not (eieio-instance-tracker-find 'die 'slot1 'IT-list)))) + +(defclass SINGLE (eieio-singleton) + ((a-slot :initarg :a-slot :initform t)) + "A Singleton test object.") + +(ert-deftest eieio-test-34-singletons () + (let ((obj1 (SINGLE)) + (obj2 (SINGLE))) + (should (eieio-object-p obj1)) + (should (eieio-object-p obj2)) + (should (eq obj1 obj2)) + (should (oref obj1 a-slot)))) + +(defclass NAMED (eieio-named) + ((some-slot :initform nil) + ) + "A class inheriting from eieio-named.") + +(ert-deftest eieio-test-35-named-object () + (let (N) + (should (setq N (NAMED :object-name "Foo"))) + (should (string= "Foo" (oref N object-name))) + (should-error (oref N missing-slot) :type 'invalid-slot-name) + (oset N object-name "NewName") + (should (string= "NewName" (oref N object-name))))) + +(defclass opt-test1 () + () + "Abstract base class" + :abstract t) + +(defclass opt-test2 (opt-test1) + () + "Instantiable child") + +(ert-deftest eieio-test-36-build-class-alist () + (should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2)) + (should (= (length (eieio-build-class-alist 'opt-test1 t)) 1))) + +(defclass eieio--testing () ()) + +(defmethod constructor :static ((_x eieio--testing) newname &rest _args) + (list newname 2)) + +(ert-deftest eieio-test-37-obsolete-name-in-constructor () + (should (equal (eieio--testing "toto") '("toto" 2)))) + +(ert-deftest eieio-autoload () + "Tests to see whether reftex-auc has been autoloaded" + (should + (fboundp 'eieio--defalias))) + + +(provide 'eieio-tests) + +;;; eieio-tests.el ends here diff --cc test/lisp/emacs-lisp/ert-tests.el index 83fddd15165,00000000000..fc5790c3659 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@@ -1,821 -1,0 +1,821 @@@ +;;; ert-tests.el --- ERT's self-tests -*- lexical-binding: t -*- + - ;; Copyright (C) 2007-2008, 2010-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2007-2008, 2010-2017 Free Software Foundation, Inc. + +;; Author: Christian Ohler + +;; This file is part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; This file is part of ERT, the Emacs Lisp Regression Testing tool. +;; See ert.el or the texinfo manual for more details. + +;;; Code: + +(require 'cl-lib) +(require 'ert) + +;;; Self-test that doesn't rely on ERT, for bootstrapping. + +;; This is used to test that bodies actually run. +(defvar ert--test-body-was-run) +(ert-deftest ert-test-body-runs () + (setq ert--test-body-was-run t)) + +(defun ert-self-test () + "Run ERT's self-tests and make sure they actually ran." + (let ((window-configuration (current-window-configuration))) + (let ((ert--test-body-was-run nil)) + ;; The buffer name chosen here should not compete with the default + ;; results buffer name for completion in `switch-to-buffer'. + (let ((stats (ert-run-tests-interactively "^ert-" " *ert self-tests*"))) + (cl-assert ert--test-body-was-run) + (if (zerop (ert-stats-completed-unexpected stats)) + ;; Hide results window only when everything went well. + (set-window-configuration window-configuration) + (error "ERT self-test failed")))))) + +(defun ert-self-test-and-exit () + "Run ERT's self-tests and exit Emacs. + +The exit code will be zero if the tests passed, nonzero if they +failed or if there was a problem." + (unwind-protect + (progn + (ert-self-test) + (kill-emacs 0)) + (unwind-protect + (progn + (message "Error running tests") + (backtrace)) + (kill-emacs 1)))) + + +;;; Further tests are defined using ERT. + +(ert-deftest ert-test-nested-test-body-runs () + "Test that nested test bodies run." + (let ((was-run nil)) + (let ((test (make-ert-test :body (lambda () + (setq was-run t))))) + (cl-assert (not was-run)) + (ert-run-test test) + (cl-assert was-run)))) + + +;;; Test that pass/fail works. +(ert-deftest ert-test-pass () + (let ((test (make-ert-test :body (lambda ())))) + (let ((result (ert-run-test test))) + (cl-assert (ert-test-passed-p result))))) + +(ert-deftest ert-test-fail () + (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (cl-assert (ert-test-failed-p result) t) + (cl-assert (equal (ert-test-result-with-condition-condition result) + '(ert-test-failed "failure message")) + t)))) + +(ert-deftest ert-test-fail-debug-with-condition-case () + (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) + (condition-case condition + (progn + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (cl-assert nil)) + ((error) + (cl-assert (equal condition '(ert-test-failed "failure message")) t))))) + +(ert-deftest ert-test-fail-debug-with-debugger-1 () + (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) + (let ((debugger (lambda (&rest _args) + (cl-assert nil)))) + (let ((ert-debug-on-error nil)) + (ert-run-test test))))) + +(ert-deftest ert-test-fail-debug-with-debugger-2 () + (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) + (cl-block nil + (let ((debugger (lambda (&rest _args) + (cl-return-from nil nil)))) + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (cl-assert nil))))) + +(ert-deftest ert-test-fail-debug-nested-with-debugger () + (let ((test (make-ert-test :body (lambda () + (let ((ert-debug-on-error t)) + (ert-fail "failure message")))))) + (let ((debugger (lambda (&rest _args) + (cl-assert nil nil "Assertion a")))) + (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (let ((test (make-ert-test :body (lambda () + (let ((ert-debug-on-error nil)) + (ert-fail "failure message")))))) + (cl-block nil + (let ((debugger (lambda (&rest _args) + (cl-return-from nil nil)))) + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (cl-assert nil nil "Assertion b"))))) + +(ert-deftest ert-test-error () + (let ((test (make-ert-test :body (lambda () (error "Error message"))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (cl-assert (ert-test-failed-p result) t) + (cl-assert (equal (ert-test-result-with-condition-condition result) + '(error "Error message")) + t)))) + +(ert-deftest ert-test-error-debug () + (let ((test (make-ert-test :body (lambda () (error "Error message"))))) + (condition-case condition + (progn + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (cl-assert nil)) + ((error) + (cl-assert (equal condition '(error "Error message")) t))))) + + +;;; Test that `should' works. +(ert-deftest ert-test-should () + (let ((test (make-ert-test :body (lambda () (should nil))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (cl-assert (ert-test-failed-p result) t) + (cl-assert (equal (ert-test-result-with-condition-condition result) + '(ert-test-failed ((should nil) :form nil :value nil))) + t))) + (let ((test (make-ert-test :body (lambda () (should t))))) + (let ((result (ert-run-test test))) + (cl-assert (ert-test-passed-p result) t)))) + +(ert-deftest ert-test-should-value () + (should (eql (should 'foo) 'foo)) + (should (eql (should 'bar) 'bar))) + +(ert-deftest ert-test-should-not () + (let ((test (make-ert-test :body (lambda () (should-not t))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (cl-assert (ert-test-failed-p result) t) + (cl-assert (equal (ert-test-result-with-condition-condition result) + '(ert-test-failed ((should-not t) :form t :value t))) + t))) + (let ((test (make-ert-test :body (lambda () (should-not nil))))) + (let ((result (ert-run-test test))) + (cl-assert (ert-test-passed-p result))))) + + +(ert-deftest ert-test-should-with-macrolet () + (let ((test (make-ert-test :body (lambda () + (cl-macrolet ((foo () `(progn t nil))) + (should (foo))))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (should (ert-test-failed-p result)) + (should (equal + (ert-test-result-with-condition-condition result) + '(ert-test-failed ((should (foo)) + :form (progn t nil) + :value nil))))))) + +(ert-deftest ert-test-should-error () + ;; No error. + (let ((test (make-ert-test :body (lambda () (should-error (progn)))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (should (ert-test-failed-p result)) + (should (equal (ert-test-result-with-condition-condition result) + '(ert-test-failed + ((should-error (progn)) + :form (progn) + :value nil + :fail-reason "did not signal an error")))))) + ;; A simple error. + (should (equal (should-error (error "Foo")) + '(error "Foo"))) + ;; Error of unexpected type. + (let ((test (make-ert-test :body (lambda () + (should-error (error "Foo") + :type 'singularity-error))))) + (let ((result (ert-run-test test))) + (should (ert-test-failed-p result)) + (should (equal + (ert-test-result-with-condition-condition result) + '(ert-test-failed + ((should-error (error "Foo") :type 'singularity-error) + :form (error "Foo") + :condition (error "Foo") + :fail-reason + "the error signaled did not have the expected type")))))) + ;; Error of the expected type. + (let* ((error nil) + (test (make-ert-test + :body (lambda () + (setq error + (should-error (signal 'singularity-error nil) + :type 'singularity-error)))))) + (let ((result (ert-run-test test))) + (should (ert-test-passed-p result)) + (should (equal error '(singularity-error)))))) + +(ert-deftest ert-test-should-error-subtypes () + (should-error (signal 'singularity-error nil) + :type 'singularity-error + :exclude-subtypes t) + (let ((test (make-ert-test + :body (lambda () + (should-error (signal 'arith-error nil) + :type 'singularity-error))))) + (let ((result (ert-run-test test))) + (should (ert-test-failed-p result)) + (should (equal + (ert-test-result-with-condition-condition result) + '(ert-test-failed + ((should-error (signal 'arith-error nil) + :type 'singularity-error) + :form (signal arith-error nil) + :condition (arith-error) + :fail-reason + "the error signaled did not have the expected type")))))) + (let ((test (make-ert-test + :body (lambda () + (should-error (signal 'arith-error nil) + :type 'singularity-error + :exclude-subtypes t))))) + (let ((result (ert-run-test test))) + (should (ert-test-failed-p result)) + (should (equal + (ert-test-result-with-condition-condition result) + '(ert-test-failed + ((should-error (signal 'arith-error nil) + :type 'singularity-error + :exclude-subtypes t) + :form (signal arith-error nil) + :condition (arith-error) + :fail-reason + "the error signaled did not have the expected type")))))) + (let ((test (make-ert-test + :body (lambda () + (should-error (signal 'singularity-error nil) + :type 'arith-error + :exclude-subtypes t))))) + (let ((result (ert-run-test test))) + (should (ert-test-failed-p result)) + (should (equal + (ert-test-result-with-condition-condition result) + '(ert-test-failed + ((should-error (signal 'singularity-error nil) + :type 'arith-error + :exclude-subtypes t) + :form (signal singularity-error nil) + :condition (singularity-error) + :fail-reason + "the error signaled was a subtype of the expected type"))))) + )) + +(ert-deftest ert-test-skip-unless () + ;; Don't skip. + (let ((test (make-ert-test :body (lambda () (skip-unless t))))) + (let ((result (ert-run-test test))) + (should (ert-test-passed-p result)))) + ;; Skip. + (let ((test (make-ert-test :body (lambda () (skip-unless nil))))) + (let ((result (ert-run-test test))) + (should (ert-test-skipped-p result)))) + ;; Skip in case of error. + (let ((test (make-ert-test :body (lambda () (skip-unless (error "Foo")))))) + (let ((result (ert-run-test test))) + (should (ert-test-skipped-p result))))) + +(defmacro ert--test-my-list (&rest args) + "Don't use this. Instead, call `list' with ARGS, it does the same thing. + +This macro is used to test if macroexpansion in `should' works." + `(list ,@args)) + +(ert-deftest ert-test-should-failure-debugging () + "Test that `should' errors contain the information we expect them to." + (cl-loop + for (body expected-condition) in + `((,(lambda () (let ((x nil)) (should x))) + (ert-test-failed ((should x) :form x :value nil))) + (,(lambda () (let ((x t)) (should-not x))) + (ert-test-failed ((should-not x) :form x :value t))) + (,(lambda () (let ((x t)) (should (not x)))) + (ert-test-failed ((should (not x)) :form (not t) :value nil))) + (,(lambda () (let ((x nil)) (should-not (not x)))) + (ert-test-failed ((should-not (not x)) :form (not nil) :value t))) + (,(lambda () (let ((x t) (y nil)) (should-not + (ert--test-my-list x y)))) + (ert-test-failed + ((should-not (ert--test-my-list x y)) + :form (list t nil) + :value (t nil)))) + (,(lambda () (let ((_x t)) (should (error "Foo")))) + (error "Foo"))) + do + (let ((test (make-ert-test :body body))) + (condition-case actual-condition + (progn + (let ((ert-debug-on-error t)) + (ert-run-test test)) + (cl-assert nil)) + ((error) + (should (equal actual-condition expected-condition))))))) + +(defun ert-test--which-file () + "Dummy function to help test `symbol-file' for tests.") + +(ert-deftest ert-test-deftest () + (ert-deftest ert-test-abc () "foo" :tags '(bar)) + (let ((abc (ert-get-test 'ert-test-abc))) + (should (equal (ert-test-tags abc) '(bar))) + (should (equal (ert-test-documentation abc) "foo"))) + (should (equal (symbol-file 'ert-test-deftest 'ert-deftest) + (symbol-file 'ert-test--which-file 'defun))) + + (ert-deftest ert-test-def () :expected-result ':passed) + (let ((def (ert-get-test 'ert-test-def))) + (should (equal (ert-test-expected-result-type def) :passed))) + ;; :documentation keyword is forbidden + (should-error (macroexpand '(ert-deftest ghi () + :documentation "foo")))) + +(ert-deftest ert-test-record-backtrace () + (let* ((test-body (lambda () (ert-fail "foo"))) + (test (make-ert-test :body test-body)) + (result (ert-run-test test))) + (should (ert-test-failed-p result)) + (with-temp-buffer + (ert--print-backtrace (ert-test-failed-backtrace result)) + (goto-char (point-min)) + (end-of-line) + (let ((first-line (buffer-substring-no-properties (point-min) (point)))) + (should (equal first-line (format " %S()" test-body))))))) + +(ert-deftest ert-test-messages () + :tags '(:causes-redisplay) + (let* ((message-string "Test message") + (messages-buffer (get-buffer-create "*Messages*")) + (test (make-ert-test :body (lambda () (message "%s" message-string))))) + (with-current-buffer messages-buffer + (let ((result (ert-run-test test))) + (should (equal (concat message-string "\n") + (ert-test-result-messages result))))))) + +(ert-deftest ert-test-running-tests () + (let ((outer-test (ert-get-test 'ert-test-running-tests))) + (should (equal (ert-running-test) outer-test)) + (let (test1 test2 test3) + (setq test1 (make-ert-test + :name "1" + :body (lambda () + (should (equal (ert-running-test) outer-test)) + (should (equal ert--running-tests + (list test1 test2 test3 + outer-test))))) + test2 (make-ert-test + :name "2" + :body (lambda () + (should (equal (ert-running-test) outer-test)) + (should (equal ert--running-tests + (list test3 test2 outer-test))) + (ert-run-test test1))) + test3 (make-ert-test + :name "3" + :body (lambda () + (should (equal (ert-running-test) outer-test)) + (should (equal ert--running-tests + (list test3 outer-test))) + (ert-run-test test2)))) + (should (ert-test-passed-p (ert-run-test test3)))))) + +(ert-deftest ert-test-test-result-expected-p () + "Test `ert-test-result-expected-p' and (implicitly) `ert-test-result-type-p'." + ;; passing test + (let ((test (make-ert-test :body (lambda ())))) + (should (ert-test-result-expected-p test (ert-run-test test)))) + ;; unexpected failure + (let ((test (make-ert-test :body (lambda () (ert-fail "failed"))))) + (should-not (ert-test-result-expected-p test (ert-run-test test)))) + ;; expected failure + (let ((test (make-ert-test :body (lambda () (ert-fail "failed")) + :expected-result-type ':failed))) + (should (ert-test-result-expected-p test (ert-run-test test)))) + ;; `not' expected type + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(not :failed)))) + (should (ert-test-result-expected-p test (ert-run-test test)))) + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(not :passed)))) + (should-not (ert-test-result-expected-p test (ert-run-test test)))) + ;; `and' expected type + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(and :passed :failed)))) + (should-not (ert-test-result-expected-p test (ert-run-test test)))) + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(and :passed + (not :failed))))) + (should (ert-test-result-expected-p test (ert-run-test test)))) + ;; `or' expected type + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(or (and :passed :failed) + :passed)))) + (should (ert-test-result-expected-p test (ert-run-test test)))) + (let ((test (make-ert-test :body (lambda ()) + :expected-result-type '(or (and :passed :failed) + nil (not t))))) + (should-not (ert-test-result-expected-p test (ert-run-test test))))) + +;;; Test `ert-select-tests'. +(ert-deftest ert-test-select-regexp () + (should (equal (ert-select-tests "^ert-test-select-regexp$" t) + (list (ert-get-test 'ert-test-select-regexp))))) + +(ert-deftest ert-test-test-boundp () + (should (ert-test-boundp 'ert-test-test-boundp)) + (should-not (ert-test-boundp (make-symbol "ert-not-a-test")))) + +(ert-deftest ert-test-select-member () + (should (equal (ert-select-tests '(member ert-test-select-member) t) + (list (ert-get-test 'ert-test-select-member))))) + +(ert-deftest ert-test-select-test () + (should (equal (ert-select-tests (ert-get-test 'ert-test-select-test) t) + (list (ert-get-test 'ert-test-select-test))))) + +(ert-deftest ert-test-select-symbol () + (should (equal (ert-select-tests 'ert-test-select-symbol t) + (list (ert-get-test 'ert-test-select-symbol))))) + +(ert-deftest ert-test-select-and () + (let ((test (make-ert-test + :name nil + :body nil + :most-recent-result (make-ert-test-failed + :condition nil + :backtrace nil + :infos nil)))) + (should (equal (ert-select-tests `(and (member ,test) :failed) t) + (list test))))) + +(ert-deftest ert-test-select-tag () + (let ((test (make-ert-test + :name nil + :body nil + :tags '(a b)))) + (should (equal (ert-select-tests `(tag a) (list test)) (list test))) + (should (equal (ert-select-tests `(tag b) (list test)) (list test))) + (should (equal (ert-select-tests `(tag c) (list test)) '())))) + + +;;; Tests for utility functions. +(ert-deftest ert-test-proper-list-p () + (should (ert--proper-list-p '())) + (should (ert--proper-list-p '(1))) + (should (ert--proper-list-p '(1 2))) + (should (ert--proper-list-p '(1 2 3))) + (should (ert--proper-list-p '(1 2 3 4))) + (should (not (ert--proper-list-p 'a))) + (should (not (ert--proper-list-p '(1 . a)))) + (should (not (ert--proper-list-p '(1 2 . a)))) + (should (not (ert--proper-list-p '(1 2 3 . a)))) + (should (not (ert--proper-list-p '(1 2 3 4 . a)))) + (let ((a (list 1))) + (setf (cdr (last a)) a) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2))) + (setf (cdr (last a)) a) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3))) + (setf (cdr (last a)) a) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3 4))) + (setf (cdr (last a)) a) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2))) + (setf (cdr (last a)) (cdr a)) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3))) + (setf (cdr (last a)) (cdr a)) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3 4))) + (setf (cdr (last a)) (cdr a)) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3))) + (setf (cdr (last a)) (cddr a)) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3 4))) + (setf (cdr (last a)) (cddr a)) + (should (not (ert--proper-list-p a)))) + (let ((a (list 1 2 3 4))) + (setf (cdr (last a)) (cl-cdddr a)) + (should (not (ert--proper-list-p a))))) + +(ert-deftest ert-test-parse-keys-and-body () + (should (equal (ert--parse-keys-and-body '(foo)) '(nil (foo)))) + (should (equal (ert--parse-keys-and-body '(:bar foo)) '((:bar foo) nil))) + (should (equal (ert--parse-keys-and-body '(:bar foo a (b))) + '((:bar foo) (a (b))))) + (should (equal (ert--parse-keys-and-body '(:bar foo :a (b))) + '((:bar foo :a (b)) nil))) + (should (equal (ert--parse-keys-and-body '(bar foo :a (b))) + '(nil (bar foo :a (b))))) + (should-error (ert--parse-keys-and-body '(:bar foo :a)))) + + +(ert-deftest ert-test-run-tests-interactively () + :tags '(:causes-redisplay) + (let ((passing-test (make-ert-test :name 'passing-test + :body (lambda () (ert-pass)))) + (failing-test (make-ert-test :name 'failing-test + :body (lambda () (ert-fail + "failure message")))) + (skipped-test (make-ert-test :name 'skipped-test + :body (lambda () (ert-skip + "skip message"))))) + (let ((ert-debug-on-error nil)) + (let* ((buffer-name (generate-new-buffer-name " *ert-test-run-tests*")) + (messages nil) + (mock-message-fn + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) + (save-window-excursion + (unwind-protect + (let ((case-fold-search nil)) + (ert-run-tests-interactively + `(member ,passing-test ,failing-test, skipped-test) buffer-name + mock-message-fn) + (should (equal messages `(,(concat + "Ran 3 tests, 1 results were " + "as expected, 1 unexpected, " + "1 skipped")))) + (with-current-buffer buffer-name + (goto-char (point-min)) + (should (equal + (buffer-substring (point-min) + (save-excursion + (forward-line 5) + (point))) + (concat + "Selector: (member " + ")\n" + "Passed: 1\n" + "Failed: 1 (1 unexpected)\n" + "Skipped: 1\n" + "Total: 3/3\n"))))) + (when (get-buffer buffer-name) + (kill-buffer buffer-name)))))))) + +(ert-deftest ert-test-special-operator-p () + (should (ert--special-operator-p 'if)) + (should-not (ert--special-operator-p 'car)) + (should-not (ert--special-operator-p 'ert--special-operator-p)) + (let ((b (cl-gensym))) + (should-not (ert--special-operator-p b)) + (fset b 'if) + (should (ert--special-operator-p b)))) + +(ert-deftest ert-test-list-of-should-forms () + (let ((test (make-ert-test :body (lambda () + (should t) + (should (null '())) + (should nil) + (should t))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (should (equal (ert-test-result-should-forms result) + '(((should t) :form t :value t) + ((should (null '())) :form (null nil) :value t) + ((should nil) :form nil :value nil))))))) + +(ert-deftest ert-test-list-of-should-forms-observers-should-not-stack () + (let ((test (make-ert-test + :body (lambda () + (let ((test2 (make-ert-test + :body (lambda () + (should t))))) + (let ((result (ert-run-test test2))) + (should (ert-test-passed-p result)))))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (should (ert-test-passed-p result)) + (should (eql (length (ert-test-result-should-forms result)) + 1))))) + +(ert-deftest ert-test-list-of-should-forms-no-deep-copy () + (let ((test (make-ert-test :body (lambda () + (let ((obj (list 'a))) + (should (equal obj '(a))) + (setf (car obj) 'b) + (should (equal obj '(b)))))))) + (let ((result (let ((ert-debug-on-error nil)) + (ert-run-test test)))) + (should (ert-test-passed-p result)) + (should (equal (ert-test-result-should-forms result) + '(((should (equal obj '(a))) :form (equal (b) (a)) :value t + :explanation nil) + ((should (equal obj '(b))) :form (equal (b) (b)) :value t + :explanation nil) + )))))) + +(ert-deftest ert-test-string-first-line () + (should (equal (ert--string-first-line "") "")) + (should (equal (ert--string-first-line "abc") "abc")) + (should (equal (ert--string-first-line "abc\n") "abc")) + (should (equal (ert--string-first-line "foo\nbar") "foo")) + (should (equal (ert--string-first-line " foo\nbar\nbaz\n") " foo"))) + +(ert-deftest ert-test-explain-equal () + (should (equal (ert--explain-equal nil 'foo) + '(different-atoms nil foo))) + (should (equal (ert--explain-equal '(a a) '(a b)) + '(list-elt 1 (different-atoms a b)))) + (should (equal (ert--explain-equal '(1 48) '(1 49)) + '(list-elt 1 (different-atoms (48 "#x30" "?0") + (49 "#x31" "?1"))))) + (should (equal (ert--explain-equal 'nil '(a)) + '(different-types nil (a)))) + (should (equal (ert--explain-equal '(a b c) '(a b c d)) + '(proper-lists-of-different-length 3 4 (a b c) (a b c d) + first-mismatch-at 3))) + (let ((sym (make-symbol "a"))) + (should (equal (ert--explain-equal 'a sym) + `(different-symbols-with-the-same-name a ,sym))))) + +(ert-deftest ert-test-explain-equal-improper-list () + (should (equal (ert--explain-equal '(a . b) '(a . c)) + '(cdr (different-atoms b c))))) + +(ert-deftest ert-test-explain-equal-keymaps () + ;; This used to be very slow. + (should (equal (make-keymap) (make-keymap))) + (should (equal (make-sparse-keymap) (make-sparse-keymap)))) + +(ert-deftest ert-test-significant-plist-keys () + (should (equal (ert--significant-plist-keys '()) '())) + (should (equal (ert--significant-plist-keys '(a b c d e f c g p q r nil s t)) + '(a c e p s)))) + +(ert-deftest ert-test-plist-difference-explanation () + (should (equal (ert--plist-difference-explanation + '(a b c nil) '(a b)) + nil)) + (should (equal (ert--plist-difference-explanation + '(a b c t) '(a b)) + '(different-properties-for-key c (different-atoms t nil)))) + (should (equal (ert--plist-difference-explanation + '(a b c t) '(c nil a b)) + '(different-properties-for-key c (different-atoms t nil)))) + (should (equal (ert--plist-difference-explanation + '(a b c (foo . bar)) '(c (foo . baz) a b)) + '(different-properties-for-key c + (cdr + (different-atoms bar baz)))))) + +(ert-deftest ert-test-abbreviate-string () + (should (equal (ert--abbreviate-string "foo" 4 nil) "foo")) + (should (equal (ert--abbreviate-string "foo" 3 nil) "foo")) + (should (equal (ert--abbreviate-string "foo" 3 nil) "foo")) + (should (equal (ert--abbreviate-string "foo" 2 nil) "fo")) + (should (equal (ert--abbreviate-string "foo" 1 nil) "f")) + (should (equal (ert--abbreviate-string "foo" 0 nil) "")) + (should (equal (ert--abbreviate-string "bar" 4 t) "bar")) + (should (equal (ert--abbreviate-string "bar" 3 t) "bar")) + (should (equal (ert--abbreviate-string "bar" 3 t) "bar")) + (should (equal (ert--abbreviate-string "bar" 2 t) "ar")) + (should (equal (ert--abbreviate-string "bar" 1 t) "r")) + (should (equal (ert--abbreviate-string "bar" 0 t) ""))) + +(ert-deftest ert-test-explain-equal-string-properties () + (should + (equal (ert--explain-equal-including-properties #("foo" 0 1 (a b)) + "foo") + '(char 0 "f" + (different-properties-for-key a (different-atoms b nil)) + context-before "" + context-after "oo"))) + (should (equal (ert--explain-equal-including-properties + #("foo" 1 3 (a b)) + #("goo" 0 1 (c d))) + '(array-elt 0 (different-atoms (?f "#x66" "?f") + (?g "#x67" "?g"))))) + (should + (equal (ert--explain-equal-including-properties + #("foo" 0 1 (a b c d) 1 3 (a b)) + #("foo" 0 1 (c d a b) 1 2 (a foo))) + '(char 1 "o" (different-properties-for-key a (different-atoms b foo)) + context-before "f" context-after "o")))) + +(ert-deftest ert-test-equal-including-properties () + (should (equal-including-properties "foo" "foo")) + (should (ert-equal-including-properties "foo" "foo")) + + (should (equal-including-properties #("foo" 0 3 (a b)) + (propertize "foo" 'a 'b))) + (should (ert-equal-including-properties #("foo" 0 3 (a b)) + (propertize "foo" 'a 'b))) + + (should (equal-including-properties #("foo" 0 3 (a b c d)) + (propertize "foo" 'a 'b 'c 'd))) + (should (ert-equal-including-properties #("foo" 0 3 (a b c d)) + (propertize "foo" 'a 'b 'c 'd))) + + (should-not (equal-including-properties #("foo" 0 3 (a b c e)) + (propertize "foo" 'a 'b 'c 'd))) + (should-not (ert-equal-including-properties #("foo" 0 3 (a b c e)) + (propertize "foo" 'a 'b 'c 'd))) + + ;; This is bug 6581. + (should-not (equal-including-properties #("foo" 0 3 (a (t))) + (propertize "foo" 'a (list t)))) + (should (ert-equal-including-properties #("foo" 0 3 (a (t))) + (propertize "foo" 'a (list t))))) + +(ert-deftest ert-test-stats-set-test-and-result () + (let* ((test-1 (make-ert-test :name 'test-1 + :body (lambda () nil))) + (test-2 (make-ert-test :name 'test-2 + :body (lambda () nil))) + (test-3 (make-ert-test :name 'test-2 + :body (lambda () nil))) + (stats (ert--make-stats (list test-1 test-2) 't)) + (failed (make-ert-test-failed :condition nil + :backtrace nil + :infos nil)) + (skipped (make-ert-test-skipped :condition nil + :backtrace nil + :infos nil))) + (should (eql 2 (ert-stats-total stats))) + (should (eql 0 (ert-stats-completed stats))) + (should (eql 0 (ert-stats-completed-expected stats))) + (should (eql 0 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 0 test-1 (make-ert-test-passed)) + (should (eql 2 (ert-stats-total stats))) + (should (eql 1 (ert-stats-completed stats))) + (should (eql 1 (ert-stats-completed-expected stats))) + (should (eql 0 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 0 test-1 failed) + (should (eql 2 (ert-stats-total stats))) + (should (eql 1 (ert-stats-completed stats))) + (should (eql 0 (ert-stats-completed-expected stats))) + (should (eql 1 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 0 test-1 nil) + (should (eql 2 (ert-stats-total stats))) + (should (eql 0 (ert-stats-completed stats))) + (should (eql 0 (ert-stats-completed-expected stats))) + (should (eql 0 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 0 test-3 failed) + (should (eql 2 (ert-stats-total stats))) + (should (eql 1 (ert-stats-completed stats))) + (should (eql 0 (ert-stats-completed-expected stats))) + (should (eql 1 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 1 test-2 (make-ert-test-passed)) + (should (eql 2 (ert-stats-total stats))) + (should (eql 2 (ert-stats-completed stats))) + (should (eql 1 (ert-stats-completed-expected stats))) + (should (eql 1 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 0 test-1 (make-ert-test-passed)) + (should (eql 2 (ert-stats-total stats))) + (should (eql 2 (ert-stats-completed stats))) + (should (eql 2 (ert-stats-completed-expected stats))) + (should (eql 0 (ert-stats-completed-unexpected stats))) + (should (eql 0 (ert-stats-skipped stats))) + (ert--stats-set-test-and-result stats 0 test-1 skipped) + (should (eql 2 (ert-stats-total stats))) + (should (eql 2 (ert-stats-completed stats))) + (should (eql 1 (ert-stats-completed-expected stats))) + (should (eql 0 (ert-stats-completed-unexpected stats))) + (should (eql 1 (ert-stats-skipped stats))))) + + +(provide 'ert-tests) + +;;; ert-tests.el ends here diff --cc test/lisp/emacs-lisp/ert-x-tests.el index ef8642aebfb,00000000000..4615d08e303 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/ert-x-tests.el +++ b/test/lisp/emacs-lisp/ert-x-tests.el @@@ -1,280 -1,0 +1,280 @@@ +;;; ert-x-tests.el --- Tests for ert-x.el + - ;; Copyright (C) 2008, 2010-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2008, 2010-2017 Free Software Foundation, Inc. + +;; Author: Phil Hagelberg +;; Christian Ohler + +;; This file is part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; This file is part of ERT, the Emacs Lisp Regression Testing tool. +;; See ert.el or the texinfo manual for more details. + +;;; Code: + +(eval-when-compile + (require 'cl-lib)) +(require 'ert) +(require 'ert-x) + +;;; Utilities + +(ert-deftest ert-test-buffer-string-reindented () + (ert-with-test-buffer (:name "well-indented") + (insert (concat "(hello (world\n" + " 'elisp)\n")) + (emacs-lisp-mode) + (should (equal (ert-buffer-string-reindented) (buffer-string)))) + (ert-with-test-buffer (:name "badly-indented") + (insert (concat "(hello\n" + " world)")) + (emacs-lisp-mode) + (should-not (equal (ert-buffer-string-reindented) (buffer-string))))) + +(defun ert--hash-table-to-alist (table) + (let ((accu nil)) + (maphash (lambda (key value) + (push (cons key value) accu)) + table) + (nreverse accu))) + +(ert-deftest ert-test-test-buffers () + (let (buffer-1 + buffer-2) + (let ((test-1 + (make-ert-test + :name 'test-1 + :body (lambda () + (ert-with-test-buffer (:name "foo") + (should (string-match + "[*]Test buffer (ert-test-test-buffers): foo[*]" + (buffer-name))) + (setq buffer-1 (current-buffer)))))) + (test-2 + (make-ert-test + :name 'test-2 + :body (lambda () + (ert-with-test-buffer (:name "bar") + (should (string-match + "[*]Test buffer (ert-test-test-buffers): bar[*]" + (buffer-name))) + (setq buffer-2 (current-buffer)) + (ert-fail "fail for test")))))) + (let ((ert--test-buffers (make-hash-table :weakness t))) + (ert-run-tests `(member ,test-1 ,test-2) #'ignore) + (should (equal (ert--hash-table-to-alist ert--test-buffers) + `((,buffer-2 . t)))) + (should-not (buffer-live-p buffer-1)) + (should (buffer-live-p buffer-2)))))) + + +(ert-deftest ert-filter-string () + (should (equal (ert-filter-string "foo bar baz" "quux") + "foo bar baz")) + (should (equal (ert-filter-string "foo bar baz" "bar") + "foo baz"))) + +(ert-deftest ert-propertized-string () + (should (ert-equal-including-properties + (ert-propertized-string "a" '(a b) "b" '(c t) "cd") + #("abcd" 1 2 (a b) 2 4 (c t)))) + (should (ert-equal-including-properties + (ert-propertized-string "foo " '(face italic) "bar" " baz" nil + " quux") + #("foo bar baz quux" 4 11 (face italic))))) + + +;;; Tests for ERT itself that require test features from ert-x.el. + +(ert-deftest ert-test-run-tests-interactively-2 () + :tags '(:causes-redisplay) + (let* ((passing-test (make-ert-test :name 'passing-test + :body (lambda () (ert-pass)))) + (failing-test (make-ert-test :name 'failing-test + :body (lambda () + (ert-info ((propertize "foo\nbar" + 'a 'b)) + (ert-fail + "failure message"))))) + (skipped-test (make-ert-test :name 'skipped-test + :body (lambda () (ert-skip + "skip message")))) + (ert-debug-on-error nil) + (buffer-name (generate-new-buffer-name "*ert-test-run-tests*")) + (messages nil) + (mock-message-fn + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) + (cl-flet ((expected-string (with-font-lock-p) + (ert-propertized-string + "Selector: (member " + ")\n" + "Passed: 1\n" + "Failed: 1 (1 unexpected)\n" + "Skipped: 1\n" + "Total: 3/3\n\n" + "Started at:\n" + "Finished.\n" + "Finished at:\n\n" + `(category ,(button-category-symbol + 'ert--results-progress-bar-button) + button (t) + face ,(if with-font-lock-p + 'ert-test-result-unexpected + 'button)) + ".Fs" nil "\n\n" + `(category ,(button-category-symbol + 'ert--results-expand-collapse-button) + button (t) + face ,(if with-font-lock-p + 'ert-test-result-unexpected + 'button)) + "F" nil " " + `(category ,(button-category-symbol + 'ert--test-name-button) + button (t) + ert-test-name failing-test) + "failing-test" + nil "\n Info: " '(a b) "foo\n" + nil " " '(a b) "bar" + nil "\n (ert-test-failed \"failure message\")\n\n\n" + ))) + (save-window-excursion + (unwind-protect + (let ((case-fold-search nil)) + (ert-run-tests-interactively + `(member ,passing-test ,failing-test ,skipped-test) buffer-name + mock-message-fn) + (should (equal messages `(,(concat + "Ran 3 tests, 1 results were " + "as expected, 1 unexpected, " + "1 skipped")))) + (with-current-buffer buffer-name + (font-lock-mode 0) + (should (ert-equal-including-properties + (ert-filter-string (buffer-string) + '("Started at:\\(.*\\)$" 1) + '("Finished at:\\(.*\\)$" 1)) + (expected-string nil))) + ;; `font-lock-mode' only works if interactive, so + ;; pretend we are. + (let ((noninteractive nil)) + (font-lock-mode 1)) + (should (ert-equal-including-properties + (ert-filter-string (buffer-string) + '("Started at:\\(.*\\)$" 1) + '("Finished at:\\(.*\\)$" 1)) + (expected-string t))))) + (when (get-buffer buffer-name) + (kill-buffer buffer-name))))))) + +(ert-deftest ert-test-describe-test () + "Tests `ert-describe-test'." + (save-window-excursion + (ert-with-buffer-renamed ("*Help*") + (if (< emacs-major-version 24) + (should (equal (should-error (ert-describe-test 'ert-describe-test)) + '(error "Requires Emacs 24"))) + (ert-describe-test 'ert-test-describe-test) + (with-current-buffer "*Help*" + (let ((case-fold-search nil)) + (should (string-match (concat + "\\`ert-test-describe-test is a test" + " defined in" + " ['`‘]ert-x-tests.elc?['’]\\.\n\n" + "Tests ['`‘]ert-describe-test['’]\\.\n\\'") + (buffer-string))))))))) + +(ert-deftest ert-test-message-log-truncation () + :tags '(:causes-redisplay) + (let ((test (make-ert-test + :body (lambda () + ;; Emacs would combine messages if we + ;; generate the same message multiple + ;; times. + (message "a") + (message "b") + (message "c") + (message "d"))))) + (let (result) + (ert-with-buffer-renamed ("*Messages*") + (let ((message-log-max 2)) + (setq result (ert-run-test test))) + (should (equal (with-current-buffer "*Messages*" + (buffer-string)) + "c\nd\n"))) + (should (equal (ert-test-result-messages result) "a\nb\nc\nd\n"))))) + +(ert-deftest ert-test-builtin-message-log-flushing () + "This test attempts to demonstrate that there is no way to +force immediate truncation of the *Messages* buffer from Lisp +\(and hence justifies the existence of +`ert--force-message-log-buffer-truncation'): The only way that +came to my mind was \(message \"\"), which doesn't have the +desired effect." + :tags '(:causes-redisplay) + (ert-with-buffer-renamed ("*Messages*") + (with-current-buffer "*Messages*" + (should (equal (buffer-string) "")) + ;; We used to get sporadic failures in this test that involved + ;; a spurious newline at the beginning of the buffer, before + ;; the first message. Below, we print a message and erase the + ;; buffer since this seems to eliminate the sporadic failures. + (message "foo") + (erase-buffer) + (should (equal (buffer-string) "")) + (let ((message-log-max 2)) + (let ((message-log-max t)) + (cl-loop for i below 4 do + (message "%s" i)) + (should (equal (buffer-string) "0\n1\n2\n3\n"))) + (should (equal (buffer-string) "0\n1\n2\n3\n")) + (message "") + (should (equal (buffer-string) "0\n1\n2\n3\n")) + (message "Test message") + (should (equal (buffer-string) "3\nTest message\n")))))) + +(ert-deftest ert-test-force-message-log-buffer-truncation () + :tags '(:causes-redisplay) + (cl-labels ((body () + (cl-loop for i below 3 do + (message "%s" i))) + ;; Uses the implicit messages buffer truncation implemented + ;; in Emacs' C core. + (c (x) + (ert-with-buffer-renamed ("*Messages*") + (let ((message-log-max x)) + (body)) + (with-current-buffer "*Messages*" + (buffer-string)))) + ;; Uses our lisp reimplementation. + (lisp (x) + (ert-with-buffer-renamed ("*Messages*") + (let ((message-log-max t)) + (body)) + (let ((message-log-max x)) + (ert--force-message-log-buffer-truncation)) + (with-current-buffer "*Messages*" + (buffer-string))))) + (cl-loop for x in '(0 1 2 3 4 t) do + (should (equal (c x) (lisp x)))))) + + +(provide 'ert-x-tests) + +;;; ert-x-tests.el ends here diff --cc test/lisp/emacs-lisp/generator-tests.el index 8ed0f2a240d,00000000000..1a567ac70fc mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@@ -1,284 -1,0 +1,284 @@@ +;;; generator-tests.el --- Testing generators -*- lexical-binding: t -*- + - ;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2017 Free Software Foundation, Inc. + +;; Author: Daniel Colascione +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +(require 'generator) +(require 'ert) +(require 'cl-lib) + +(defun generator-list-subrs () + (cl-loop for x being the symbols + when (and (fboundp x) + (cps--special-form-p (symbol-function x))) + collect x)) + +(defmacro cps-testcase (name &rest body) + "Perform a simple test of the continuation-transforming code. + +`cps-testcase' defines an ERT testcase called NAME that evaluates +BODY twice: once using ordinary `eval' and once using +lambda-generators. The test ensures that the two forms produce +identical output. +" + `(progn + (ert-deftest ,name () + (should + (equal + (funcall (lambda () ,@body)) + (iter-next + (funcall + (iter-lambda () (iter-yield (progn ,@body)))))))) + (ert-deftest ,(intern (format "%s-noopt" name)) () + (should + (equal + (funcall (lambda () ,@body)) + (iter-next + (funcall + (let ((cps-inhibit-atomic-optimization t)) + (iter-lambda () (iter-yield (progn ,@body))))))))))) + +(put 'cps-testcase 'lisp-indent-function 1) + +(defvar *cps-test-i* nil) +(defun cps-get-test-i () + *cps-test-i*) + +(cps-testcase cps-simple-1 (progn 1 2 3)) +(cps-testcase cps-empty-progn (progn)) +(cps-testcase cps-inline-not-progn (inline 1 2 3)) +(cps-testcase cps-prog1-a (prog1 1 2 3)) +(cps-testcase cps-prog1-b (prog1 1)) +(cps-testcase cps-prog1-c (prog2 1 2 3)) +(cps-testcase cps-quote (progn 'hello)) +(cps-testcase cps-function (progn #'hello)) + +(cps-testcase cps-and-fail (and 1 nil 2)) +(cps-testcase cps-and-succeed (and 1 2 3)) +(cps-testcase cps-and-empty (and)) + +(cps-testcase cps-or-fallthrough (or nil 1 2)) +(cps-testcase cps-or-alltrue (or 1 2 3)) +(cps-testcase cps-or-empty (or)) + +(cps-testcase cps-let* (let* ((i 10)) i)) +(cps-testcase cps-let*-shadow-empty (let* ((i 10)) (let (i) i))) +(cps-testcase cps-let (let ((i 10)) i)) +(cps-testcase cps-let-shadow-empty (let ((i 10)) (let (i) i))) +(cps-testcase cps-let-novars (let nil 42)) +(cps-testcase cps-let*-novars (let* nil 42)) + +(cps-testcase cps-let-parallel + (let ((a 5) (b 6)) (let ((a b) (b a)) (list a b)))) + +(cps-testcase cps-let*-parallel + (let* ((a 5) (b 6)) (let* ((a b) (b a)) (list a b)))) + +(cps-testcase cps-while-dynamic + (setq *cps-test-i* 0) + (while (< *cps-test-i* 10) + (setf *cps-test-i* (+ *cps-test-i* 1))) + *cps-test-i*) + +(cps-testcase cps-while-lexical + (let* ((i 0) (j 10)) + (while (< i 10) + (setf i (+ i 1)) + (setf j (+ j (* i 10)))) + j)) + +(cps-testcase cps-while-incf + (let* ((i 0) (j 10)) + (while (< i 10) + (cl-incf i) + (setf j (+ j (* i 10)))) + j)) + +(cps-testcase cps-dynbind + (setf *cps-test-i* 0) + (let* ((*cps-test-i* 5)) + (cps-get-test-i))) + +(cps-testcase cps-nested-application + (+ (+ 3 5) 1)) + +(cps-testcase cps-unwind-protect + (setf *cps-test-i* 0) + (unwind-protect + (setf *cps-test-i* 1) + (setf *cps-test-i* 2)) + *cps-test-i*) + +(cps-testcase cps-catch-unused + (catch 'mytag 42)) + +(cps-testcase cps-catch-thrown + (1+ (catch 'mytag + (throw 'mytag (+ 2 2))))) + +(cps-testcase cps-loop + (cl-loop for x from 1 to 10 collect x)) + +(cps-testcase cps-loop-backquote + `(a b ,(cl-loop for x from 1 to 10 collect x) -1)) + +(cps-testcase cps-if-branch-a + (if t 'abc)) + +(cps-testcase cps-if-branch-b + (if t 'abc 'def)) + +(cps-testcase cps-if-condition-fail + (if nil 'abc 'def)) + +(cps-testcase cps-cond-empty + (cond)) + +(cps-testcase cps-cond-atomi + (cond (42))) + +(cps-testcase cps-cond-complex + (cond (nil 22) ((1+ 1) 42) (t 'bad))) + +(put 'cps-test-error 'error-conditions '(cps-test-condition)) + +(cps-testcase cps-condition-case + (condition-case + condvar + (signal 'cps-test-error 'test-data) + (cps-test-condition condvar))) + +(cps-testcase cps-condition-case-no-error + (condition-case + condvar + 42 + (cps-test-condition condvar))) + +(ert-deftest cps-generator-basic () + (let* ((gen (iter-lambda () + (iter-yield 1) + (iter-yield 2) + (iter-yield 3) + 4)) + (gen-inst (funcall gen))) + (should (eql (iter-next gen-inst) 1)) + (should (eql (iter-next gen-inst) 2)) + (should (eql (iter-next gen-inst) 3)) + + ;; should-error doesn't catch the generator-end condition (which + ;; isn't an error), so we write our own. + (let (errored) + (condition-case x + (iter-next gen-inst) + (iter-end-of-sequence + (setf errored (cdr x)))) + (should (eql errored 4))))) + +(iter-defun mygenerator (i) + (iter-yield 1) + (iter-yield i) + (iter-yield 2)) + +(ert-deftest cps-test-iter-do () + (let (mylist) + (iter-do (x (mygenerator 4)) + (push x mylist)) + (should (equal mylist '(2 4 1))))) + +(iter-defun gen-using-yield-value () + (let (f) + (setf f (iter-yield 42)) + (iter-yield f) + -8)) + +(ert-deftest cps-yield-value () + (let ((it (gen-using-yield-value))) + (should (eql (iter-next it -1) 42)) + (should (eql (iter-next it -1) -1)))) + +(ert-deftest cps-loop () + (should + (equal (cl-loop for x iter-by (mygenerator 42) + collect x) + '(1 42 2)))) + +(iter-defun gen-using-yield-from () + (let ((sub-iter (gen-using-yield-value))) + (iter-yield (1+ (iter-yield-from sub-iter))))) + +(ert-deftest cps-test-yield-from-works () + (let ((it (gen-using-yield-from))) + (should (eql (iter-next it -1) 42)) + (should (eql (iter-next it -1) -1)) + (should (eql (iter-next it -1) -7)))) + +(defvar cps-test-closed-flag nil) + +(ert-deftest cps-test-iter-close () + (garbage-collect) + (let ((cps-test-closed-flag nil)) + (let ((iter (funcall + (iter-lambda () + (unwind-protect (iter-yield 1) + (setf cps-test-closed-flag t)))))) + (should (equal (iter-next iter) 1)) + (should (not cps-test-closed-flag)) + (iter-close iter) + (should cps-test-closed-flag)))) + +(ert-deftest cps-test-iter-close-idempotent () + (garbage-collect) + (let ((cps-test-closed-flag nil)) + (let ((iter (funcall + (iter-lambda () + (unwind-protect (iter-yield 1) + (setf cps-test-closed-flag t)))))) + (should (equal (iter-next iter) 1)) + (should (not cps-test-closed-flag)) + (iter-close iter) + (should cps-test-closed-flag) + (setf cps-test-closed-flag nil) + (iter-close iter) + (should (not cps-test-closed-flag))))) + +(ert-deftest cps-test-iter-cleanup-once-only () + (let* ((nr-unwound 0) + (iter + (funcall (iter-lambda () + (unwind-protect + (progn + (iter-yield 1) + (error "test") + (iter-yield 2)) + (cl-incf nr-unwound)))))) + (should (equal (iter-next iter) 1)) + (should-error (iter-next iter)) + (should (equal nr-unwound 1)))) + +(iter-defun generator-with-docstring () + "Documentation!" + (declare (indent 5)) + nil) + +(ert-deftest cps-test-declarations-preserved () + (should (equal (documentation 'generator-with-docstring) "Documentation!")) + (should (equal (get 'generator-with-docstring 'lisp-indent-function) 5))) diff --cc test/lisp/emacs-lisp/let-alist-tests.el index 657a27a67dc,00000000000..fbcde4e3cbf mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/let-alist-tests.el +++ b/test/lisp/emacs-lisp/let-alist-tests.el @@@ -1,99 -1,0 +1,99 @@@ +;;; let-alist.el --- tests for file handling. -*- lexical-binding: t; -*- + - ;; Copyright (C) 2012-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2012-2017 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'let-alist) + +(ert-deftest let-alist-surface-test () + "Tests basic macro expansion for `let-alist'." + (should + (equal '(let ((symbol data)) + (let ((.test-one (cdr (assq 'test-one symbol))) + (.test-two (cdr (assq 'test-two symbol)))) + (list .test-one .test-two + .test-two .test-two))) + (cl-letf (((symbol-function #'make-symbol) (lambda (x) 'symbol))) + (macroexpand + '(let-alist data (list .test-one .test-two + .test-two .test-two)))))) + (should + (equal + (let ((.external "ext") + (.external.too "et")) + (let-alist '((test-two . 0) + (test-three . 1) + (sublist . ((foo . 2) + (bar . 3)))) + (list .test-one .test-two .test-three + .sublist.foo .sublist.bar + ..external ..external.too))) + (list nil 0 1 2 3 "ext" "et")))) + +(ert-deftest let-alist-cons () + (should + (equal + (let ((.external "ext") + (.external.too "et")) + (let-alist '((test-two . 0) + (test-three . 1) + (sublist . ((foo . 2) + (bar . 3)))) + (list `(, .test-one . , .test-two) + .sublist.bar ..external))) + (list '(nil . 0) 3 "ext")))) + +(defvar let-alist--test-counter 0 + "Used to count number of times a function is called.") + +(ert-deftest let-alist-evaluate-once () + "Check that the alist argument is only evaluated once." + (let ((let-alist--test-counter 0)) + (should + (equal + (let-alist (list + (cons 'test-two (cl-incf let-alist--test-counter)) + (cons 'test-three (cl-incf let-alist--test-counter))) + (list .test-one .test-two .test-two .test-three .cl-incf)) + '(nil 1 1 2 nil))))) + +(ert-deftest let-alist-remove-dot () + "Remove first dot from symbol." + (should (equal (let-alist--remove-dot 'hi) 'hi)) + (should (equal (let-alist--remove-dot '.hi) 'hi)) + (should (equal (let-alist--remove-dot '..hi) '.hi))) + +(ert-deftest let-alist-list-to-sexp () + "Check that multiple dots are handled correctly." + (should (= 1 (eval (let-alist--list-to-sexp '(a b c d) ''((d (c (b (a . 1))))))))) + (should (equal (let-alist--access-sexp '.foo.bar.baz 'var) + '(cdr (assq 'baz (cdr (assq 'bar (cdr (assq 'foo var)))))))) + (should (equal (let-alist--access-sexp '..foo.bar.baz 'var) '.foo.bar.baz))) + +(ert-deftest let-alist--deep-dot-search--nested () + "Check that nested `let-alist' forms don't generate spurious bindings. +See Bug#24641." + (should (equal (let-alist--deep-dot-search '(foo .bar (baz .qux))) + '((.bar . bar) (.qux . qux)))) + (should (equal (let-alist--deep-dot-search '(foo .bar (let-alist .qux .baz))) + '((.bar . bar) (.qux . qux))))) ; no .baz + +;;; let-alist.el ends here diff --cc test/lisp/emacs-lisp/map-tests.el index 0af1c656e09,00000000000..07e85cc5391 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@@ -1,346 -1,0 +1,346 @@@ +;;; map-tests.el --- Tests for map.el -*- lexical-binding:t -*- + - ;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2017 Free Software Foundation, Inc. + +;; Author: Nicolas Petton +;; Maintainer: emacs-devel@gnu.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Tests for map.el + +;;; Code: + +(require 'ert) +(require 'map) + +(defmacro with-maps-do (var &rest body) + "Successively bind VAR to an alist, vector and hash-table. +Each map is built from the following alist data: +'((0 . 3) (1 . 4) (2 . 5)). +Evaluate BODY for each created map. + +\(fn (var map) body)" + (declare (indent 1) (debug t)) + (let ((alist (make-symbol "alist")) + (vec (make-symbol "vec")) + (ht (make-symbol "ht"))) + `(let ((,alist (list (cons 0 3) + (cons 1 4) + (cons 2 5))) + (,vec (vector 3 4 5)) + (,ht (make-hash-table))) + (puthash 0 3 ,ht) + (puthash 1 4 ,ht) + (puthash 2 5 ,ht) + (dolist (,var (list ,alist ,vec ,ht)) + ,@body)))) + +(ert-deftest test-map-elt () + (with-maps-do map + (should (= 3 (map-elt map 0))) + (should (= 4 (map-elt map 1))) + (should (= 5 (map-elt map 2))) + (should (null (map-elt map -1))) + (should (null (map-elt map 4))))) + +(ert-deftest test-map-elt-default () + (with-maps-do map + (should (= 5 (map-elt map 7 5))))) + +(ert-deftest test-map-elt-with-nil-value () + (should (null (map-elt '((a . 1) + (b)) + 'b + '2)))) + +(ert-deftest test-map-put () + (with-maps-do map + (setf (map-elt map 2) 'hello) + (should (eq (map-elt map 2) 'hello))) + (with-maps-do map + (map-put map 2 'hello) + (should (eq (map-elt map 2) 'hello))) + (let ((ht (make-hash-table))) + (setf (map-elt ht 2) 'a) + (should (eq (map-elt ht 2) + 'a))) + (let ((alist '((0 . a) (1 . b) (2 . c)))) + (setf (map-elt alist 2) 'a) + (should (eq (map-elt alist 2) + 'a))) + (let ((vec [3 4 5])) + (should-error (setf (map-elt vec 3) 6)))) + +(ert-deftest test-map-put-alist-new-key () + "Regression test for Bug#23105." + (let ((alist '((0 . a)))) + (map-put alist 2 'b) + (should (eq (map-elt alist 2) + 'b)))) + +(ert-deftest test-map-put-return-value () + (let ((ht (make-hash-table))) + (should (eq (map-put ht 'a 'hello) 'hello)))) + +(ert-deftest test-map-delete () + (with-maps-do map + (map-delete map 1) + (should (null (map-elt map 1)))) + (with-maps-do map + (map-delete map -2) + (should (null (map-elt map -2))))) + +(ert-deftest test-map-delete-return-value () + (let ((ht (make-hash-table))) + (should (eq (map-delete ht 'a) ht)))) + +(ert-deftest test-map-nested-elt () + (let ((vec [a b [c d [e f]]])) + (should (eq (map-nested-elt vec '(2 2 0)) 'e))) + (let ((alist '((a . 1) + (b . ((c . 2) + (d . 3) + (e . ((f . 4) + (g . 5)))))))) + (should (eq (map-nested-elt alist '(b e f)) + 4))) + (let ((ht (make-hash-table))) + (setf (map-elt ht 'a) 1) + (setf (map-elt ht 'b) (make-hash-table)) + (setf (map-elt (map-elt ht 'b) 'c) 2) + (should (eq (map-nested-elt ht '(b c)) + 2)))) + +(ert-deftest test-map-nested-elt-default () + (let ((vec [a b [c d]])) + (should (null (map-nested-elt vec '(2 3)))) + (should (null (map-nested-elt vec '(2 1 1)))) + (should (= 4 (map-nested-elt vec '(2 1 1) 4))))) + +(ert-deftest test-mapp () + (should (mapp nil)) + (should (mapp '((a . b) (c . d)))) + (should (mapp '(a b c d))) + (should (mapp [])) + (should (mapp [1 2 3])) + (should (mapp (make-hash-table))) + (should (mapp "hello")) + (should (not (mapp 1))) + (should (not (mapp 'hello)))) + +(ert-deftest test-map-keys () + (with-maps-do map + (should (equal (map-keys map) '(0 1 2)))) + (should (null (map-keys nil))) + (should (null (map-keys [])))) + +(ert-deftest test-map-values () + (with-maps-do map + (should (equal (map-values map) '(3 4 5))))) + +(ert-deftest test-map-pairs () + (with-maps-do map + (should (equal (map-pairs map) '((0 . 3) + (1 . 4) + (2 . 5)))))) + +(ert-deftest test-map-length () + (let ((ht (make-hash-table))) + (puthash 'a 1 ht) + (puthash 'b 2 ht) + (puthash 'c 3 ht) + (puthash 'd 4 ht) + (should (= 0 (map-length nil))) + (should (= 0 (map-length []))) + (should (= 0 (map-length (make-hash-table)))) + (should (= 5 (map-length [0 1 2 3 4]))) + (should (= 2 (map-length '((a . 1) (b . 2))))) + (should (= 4 (map-length ht))))) + +(ert-deftest test-map-copy () + (with-maps-do map + (let ((copy (map-copy map))) + (should (equal (map-keys map) (map-keys copy))) + (should (equal (map-values map) (map-values copy))) + (should (not (eq map copy)))))) + +(ert-deftest test-map-apply () + (with-maps-do map + (should (equal (map-apply (lambda (k v) (cons (int-to-string k) v)) + map) + '(("0" . 3) ("1" . 4) ("2" . 5))))) + (let ((vec [a b c])) + (should (equal (map-apply (lambda (k v) (cons (1+ k) v)) + vec) + '((1 . a) + (2 . b) + (3 . c)))))) + +(ert-deftest test-map-do () + (with-maps-do map + (let ((result nil)) + (map-do (lambda (k v) + (add-to-list 'result (list (int-to-string k) v))) + map) + (should (equal result '(("2" 5) ("1" 4) ("0" 3))))))) + +(ert-deftest test-map-keys-apply () + (with-maps-do map + (should (equal (map-keys-apply (lambda (k) (int-to-string k)) + map) + '("0" "1" "2")))) + (let ((vec [a b c])) + (should (equal (map-keys-apply (lambda (k) (1+ k)) + vec) + '(1 2 3))))) + +(ert-deftest test-map-values-apply () + (with-maps-do map + (should (equal (map-values-apply (lambda (v) (1+ v)) + map) + '(4 5 6)))) + (let ((vec [a b c])) + (should (equal (map-values-apply (lambda (v) (symbol-name v)) + vec) + '("a" "b" "c"))))) + +(ert-deftest test-map-filter () + (with-maps-do map + (should (equal (map-keys (map-filter (lambda (_k v) + (<= 4 v)) + map)) + '(1 2))) + (should (null (map-filter (lambda (k _v) + (eq 'd k)) + map)))) + (should (null (map-filter (lambda (_k v) + (eq 3 v)) + [1 2 4 5]))) + (should (equal (map-filter (lambda (k _v) + (eq 3 k)) + [1 2 4 5]) + '((3 . 5))))) + +(ert-deftest test-map-remove () + (with-maps-do map + (should (equal (map-keys (map-remove (lambda (_k v) + (>= v 4)) + map)) + '(0))) + (should (equal (map-keys (map-remove (lambda (k _v) + (eq 'd k)) + map)) + (map-keys map)))) + (should (equal (map-remove (lambda (_k v) + (eq 3 v)) + [1 2 4 5]) + '((0 . 1) + (1 . 2) + (2 . 4) + (3 . 5)))) + (should (null (map-remove (lambda (k _v) + (>= k 0)) + [1 2 4 5])))) + +(ert-deftest test-map-empty-p () + (should (map-empty-p nil)) + (should (not (map-empty-p '((a . b) (c . d))))) + (should (map-empty-p [])) + (should (not (map-empty-p [1 2 3]))) + (should (map-empty-p (make-hash-table))) + (should (not (map-empty-p "hello"))) + (should (map-empty-p ""))) + +(ert-deftest test-map-contains-key () + (should (map-contains-key '((a . 1) (b . 2)) 'a)) + (should (not (map-contains-key '((a . 1) (b . 2)) 'c))) + (should (map-contains-key '(("a" . 1)) "a")) + (should (not (map-contains-key '(("a" . 1)) "a" #'eq))) + (should (map-contains-key [a b c] 2)) + (should (not (map-contains-key [a b c] 3)))) + +(ert-deftest test-map-some () + (with-maps-do map + (should (map-some (lambda (k _v) + (eq 1 k)) + map)) + (should-not (map-some (lambda (k _v) + (eq 'd k)) + map))) + (let ((vec [a b c])) + (should (map-some (lambda (k _v) + (> k 1)) + vec)) + (should-not (map-some (lambda (k _v) + (> k 3)) + vec)))) + +(ert-deftest test-map-every-p () + (with-maps-do map + (should (map-every-p (lambda (k _v) + k) + map)) + (should (not (map-every-p (lambda (_k _v) + nil) + map)))) + (let ((vec [a b c])) + (should (map-every-p (lambda (k _v) + (>= k 0)) + vec)) + (should (not (map-every-p (lambda (k _v) + (> k 3)) + vec))))) + +(ert-deftest test-map-into () + (let* ((alist '((a . 1) (b . 2))) + (ht (map-into alist 'hash-table))) + (should (hash-table-p ht)) + (should (equal (map-into (map-into alist 'hash-table) 'list) + alist)) + (should (listp (map-into ht 'list))) + (should (equal (map-keys (map-into (map-into ht 'list) 'hash-table)) + (map-keys ht))) + (should (equal (map-values (map-into (map-into ht 'list) 'hash-table)) + (map-values ht))) + (should (null (map-into nil 'list))) + (should (map-empty-p (map-into nil 'hash-table))) + (should-error (map-into [1 2 3] 'string)))) + +(ert-deftest test-map-let () + (map-let (foo bar baz) '((foo . 1) (bar . 2)) + (should (= foo 1)) + (should (= bar 2)) + (should (null baz))) + (map-let (('foo a) + ('bar b) + ('baz c)) + '((foo . 1) (bar . 2)) + (should (= a 1)) + (should (= b 2)) + (should (null c)))) + +(ert-deftest test-map-merge-with () + (should (equal (map-merge-with 'list #'+ + '((1 . 2)) + '((1 . 3) (2 . 4)) + '((1 . 1) (2 . 5) (3 . 0))) + '((3 . 0) (2 . 9) (1 . 6))))) + +(provide 'map-tests) +;;; map-tests.el ends here diff --cc test/lisp/emacs-lisp/nadvice-tests.el index cd51599b86a,00000000000..b228da6cdb8 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/nadvice-tests.el +++ b/test/lisp/emacs-lisp/nadvice-tests.el @@@ -1,211 -1,0 +1,211 @@@ +;;; advice-tests.el --- Test suite for the new advice thingy. + - ;; Copyright (C) 2012-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2012-2017 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) + +(ert-deftest advice-tests-nadvice () + "Test nadvice code." + (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5))) + (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 2))) + (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5))) + (defun sm-test1 (x) (+ x 4)) + (should (equal (sm-test1 6) 20)) + (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 2))) + (should (equal (sm-test1 6) 10)) + (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 5))) + (should (equal (sm-test1 6) 50)) + (defun sm-test1 (x) (+ x 14)) + (should (equal (sm-test1 6) 100)) + (should (equal (null (get 'sm-test1 'defalias-fset-function)) nil)) + (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5))) + (should (equal (sm-test1 6) 20)) + (should (equal (get 'sm-test1 'defalias-fset-function) nil)) + + (advice-add 'sm-test3 :around + (lambda (f &rest args) `(toto ,(apply f args))) + '((name . wrap-with-toto))) + (defmacro sm-test3 (x) `(call-test3 ,x)) + (should (equal (macroexpand '(sm-test3 56)) '(toto (call-test3 56))))) + +(ert-deftest advice-tests-macroaliases () + "Test nadvice code on aliases to macros." + (defmacro sm-test1 (a) `(list ',a)) + (defalias 'sm-test1-alias 'sm-test1) + (should (equal (macroexpand '(sm-test1-alias 5)) '(list '5))) + (advice-add 'sm-test1-alias :around + (lambda (f &rest args) `(cons 1 ,(apply f args)))) + (should (equal (macroexpand '(sm-test1-alias 5)) '(cons 1 (list '5)))) + (defmacro sm-test1 (a) `(list 0 ',a)) + (should (equal (macroexpand '(sm-test1-alias 5)) '(cons 1 (list 0 '5))))) + + +(ert-deftest advice-tests-advice () + "Test advice code." + (defun sm-test2 (x) (+ x 4)) + (should (equal (sm-test2 6) 10)) + (defadvice sm-test2 (around sm-test activate) + ad-do-it (setq ad-return-value (* ad-return-value 5))) + (should (equal (sm-test2 6) 50)) + (ad-deactivate 'sm-test2) + (should (equal (sm-test2 6) 10)) + (ad-activate 'sm-test2) + (should (equal (sm-test2 6) 50)) + (defun sm-test2 (x) (+ x 14)) + (should (equal (sm-test2 6) 100)) + (should (equal (null (get 'sm-test2 'defalias-fset-function)) nil)) + (ad-remove-advice 'sm-test2 'around 'sm-test) + (should (equal (sm-test2 6) 100)) + (ad-activate 'sm-test2) + (should (equal (sm-test2 6) 20)) + (should (equal (null (get 'sm-test2 'defalias-fset-function)) t)) + + (defadvice sm-test4 (around wrap-with-toto activate) + ad-do-it (setq ad-return-value `(toto ,ad-return-value))) + (defmacro sm-test4 (x) `(call-test4 ,x)) + (should (equal (macroexpand '(sm-test4 56)) '(toto (call-test4 56)))) + (defmacro sm-test4 (x) `(call-testq ,x)) + (should (equal (macroexpand '(sm-test4 56)) '(toto (call-testq 56)))) + + ;; This used to signal an error (bug#12858). + (autoload 'sm-test6 "foo") + (defadvice sm-test6 (around test activate) + ad-do-it)) + +(ert-deftest advice-tests-combination () + "Combining old style and new style advices." + (defun sm-test5 (x) (+ x 4)) + (should (equal (sm-test5 6) 10)) + (advice-add 'sm-test5 :around (lambda (f y) (* (funcall f y) 5))) + (should (equal (sm-test5 6) 50)) + (defadvice sm-test5 (around test activate) + ad-do-it (setq ad-return-value (+ ad-return-value 0.1))) + (should (equal (sm-test5 5) 45.1)) + (ad-deactivate 'sm-test5) + (should (equal (sm-test5 6) 50)) + (ad-activate 'sm-test5) + (should (equal (sm-test5 6) 50.1)) + (defun sm-test5 (x) (+ x 14)) + (should (equal (sm-test5 6) 100.1)) + (advice-remove 'sm-test5 (lambda (f y) (* (funcall f y) 5))) + (should (equal (sm-test5 6) 20.1))) + +(ert-deftest advice-test-called-interactively-p () + "Check interaction between advice and called-interactively-p." + (defun sm-test7 (&optional x) (interactive) (+ (or x 7) 4)) + (advice-add 'sm-test7 :around + (lambda (f &rest args) + (list (cons 1 (called-interactively-p)) (apply f args)))) + (should (equal (sm-test7) '((1 . nil) 11))) + (should (equal (call-interactively 'sm-test7) '((1 . t) 11))) + (let ((smi 7)) + (advice-add 'sm-test7 :before + (lambda (&rest args) + (setq smi (called-interactively-p)))) + (should (equal (list (sm-test7) smi) + '(((1 . nil) 11) nil))) + (should (equal (list (call-interactively 'sm-test7) smi) + '(((1 . t) 11) t)))) + (advice-add 'sm-test7 :around + (lambda (f &rest args) + (cons (cons 2 (called-interactively-p)) (apply f args)))) + (should (equal (call-interactively 'sm-test7) '((2 . t) (1 . t) 11)))) + +(ert-deftest advice-test-called-interactively-p-around () + "Check interaction between around advice and called-interactively-p. + +This tests the currently broken case of the innermost advice to a +function being an around advice." + :expected-result :failed + (defun sm-test7.2 () (interactive) (cons 1 (called-interactively-p))) + (advice-add 'sm-test7.2 :around + (lambda (f &rest args) + (list (cons 1 (called-interactively-p)) (apply f args)))) + (should (equal (sm-test7.2) '((1 . nil) (1 . nil)))) + (should (equal (call-interactively 'sm-test7.2) '((1 . t) (1 . t))))) + +(ert-deftest advice-test-called-interactively-p-filter-args () + "Check interaction between filter-args advice and called-interactively-p." + :expected-result :failed + (defun sm-test7.3 () (interactive) (cons 1 (called-interactively-p))) + (advice-add 'sm-test7.3 :filter-args #'list) + (should (equal (sm-test7.3) '(1 . nil))) + (should (equal (call-interactively 'sm-test7.3) '(1 . t)))) + +(ert-deftest advice-test-call-interactively () + "Check interaction between advice on call-interactively and called-interactively-p." + (defun sm-test7.4 () (interactive) (cons 1 (called-interactively-p))) + (let ((old (symbol-function 'call-interactively))) + (unwind-protect + (progn + (advice-add 'call-interactively :before #'ignore) + (should (equal (sm-test7.4) '(1 . nil))) + (should (equal (call-interactively 'sm-test7.4) '(1 . t)))) + (advice-remove 'call-interactively #'ignore) + (should (eq (symbol-function 'call-interactively) old))))) + +(ert-deftest advice-test-interactive () + "Check handling of interactive spec." + (defun sm-test8 (a) (interactive "p") a) + (defadvice sm-test8 (before adv1 activate) nil) + (defadvice sm-test8 (before adv2 activate) (interactive "P") nil) + (should (equal (interactive-form 'sm-test8) '(interactive "P")))) + +(ert-deftest advice-test-preactivate () + (should (equal (null (get 'sm-test9 'defalias-fset-function)) t)) + (defun sm-test9 (a) (interactive "p") a) + (should (equal (null (get 'sm-test9 'defalias-fset-function)) t)) + (defadvice sm-test9 (before adv1 pre act protect compile) nil) + (should (equal (null (get 'sm-test9 'defalias-fset-function)) nil)) + (defadvice sm-test9 (before adv2 pre act protect compile) + (interactive "P") nil) + (should (equal (interactive-form 'sm-test9) '(interactive "P")))) + +(ert-deftest advice-test-multiples () + (let ((sm-test10 (lambda (a) (+ a 10))) + (sm-advice (lambda (x) (if (consp x) (list (* 5 (car x))) (* 4 x))))) + (should (equal (funcall sm-test10 5) 15)) + (add-function :filter-args (var sm-test10) sm-advice) + (should (advice-function-member-p sm-advice sm-test10)) + (should (equal (funcall sm-test10 5) 35)) + (add-function :filter-return (var sm-test10) sm-advice) + (should (equal (funcall sm-test10 5) 60)) + ;; Make sure we can add multiple times the same function, under the + ;; condition that they have different `name' properties. + (add-function :filter-args (var sm-test10) sm-advice '((name . "args"))) + (should (equal (funcall sm-test10 5) 140)) + (remove-function (var sm-test10) "args") + (should (equal (funcall sm-test10 5) 60)) + (add-function :filter-args (var sm-test10) sm-advice '((name . "args"))) + (add-function :filter-return (var sm-test10) sm-advice '((name . "ret"))) + (should (equal (funcall sm-test10 5) 560)) + ;; Make sure that if we specify to remove a function that was added + ;; multiple times, they are all removed, rather than removing only some + ;; arbitrary subset of them. + (remove-function (var sm-test10) sm-advice) + (should (equal (funcall sm-test10 5) 15)))) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +;;; advice-tests.el ends here. diff --cc test/lisp/emacs-lisp/package-tests.el index 3d2801e3d70,00000000000..2e4666e7fe3 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@@ -1,643 -1,0 +1,643 @@@ +;;; package-test.el --- Tests for the Emacs package system + - ;; Copyright (C) 2013-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + +;; Author: Daniel Hackney +;; Version: 1.0 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; You may want to run this from a separate Emacs instance from your +;; main one, because a bug in the code below could mess with your +;; installed packages. + +;; Run this in a clean Emacs session using: +;; +;; $ emacs -Q --batch -L . -l package-test.el -l ert -f ert-run-tests-batch-and-exit + +;;; Code: + +(require 'package) +(require 'ert) +(require 'cl-lib) + +(setq package-menu-async nil) + +(defvar package-test-user-dir nil + "Directory to use for installing packages during testing.") + +(defvar package-test-file-dir (file-name-directory (or load-file-name + buffer-file-name)) + "Directory of the actual \"package-test.el\" file.") + +(defvar simple-single-desc + (package-desc-create :name 'simple-single + :version '(1 3) + :summary "A single-file package with no dependencies" + :kind 'single + :extras '((:authors ("J. R. Hacker" . "jrh@example.com")) + (:maintainer "J. R. Hacker" . "jrh@example.com") + (:url . "http://doodles.au"))) + "Expected `package-desc' parsed from simple-single-1.3.el.") + +(defvar simple-depend-desc + (package-desc-create :name 'simple-depend + :version '(1 0) + :summary "A single-file package with a dependency." + :kind 'single + :reqs '((simple-single (1 3))) + :extras '((:authors ("J. R. Hacker" . "jrh@example.com")) + (:maintainer "J. R. Hacker" . "jrh@example.com"))) + "Expected `package-desc' parsed from simple-depend-1.0.el.") + +(defvar multi-file-desc + (package-desc-create :name 'multi-file + :version '(0 2 3) + :summary "Example of a multi-file tar package" + :kind 'tar + :extras '((:url . "http://puddles.li"))) + "Expected `package-desc' from \"multi-file-0.2.3.tar\".") + +(defvar new-pkg-desc + (package-desc-create :name 'new-pkg + :version '(1 0) + :kind 'single) + "Expected `package-desc' parsed from new-pkg-1.0.el.") + +(defvar simple-depend-desc-1 + (package-desc-create :name 'simple-depend-1 + :version '(1 0) + :summary "A single-file package with a dependency." + :kind 'single + :reqs '((simple-depend (1 0)) + (multi-file (0 1)))) + "`package-desc' used for testing dependencies.") + +(defvar simple-depend-desc-2 + (package-desc-create :name 'simple-depend-2 + :version '(1 0) + :summary "A single-file package with a dependency." + :kind 'single + :reqs '((simple-depend-1 (1 0)) + (multi-file (0 1)))) + "`package-desc' used for testing dependencies.") + +(defvar package-test-data-dir (expand-file-name "package-resources" package-test-file-dir) + "Base directory of package test files.") + +(defvar package-test-fake-contents-file + (expand-file-name "archive-contents" package-test-data-dir) + "Path to a static copy of \"archive-contents\".") + +(cl-defmacro with-package-test ((&optional &key file + basedir + install + location + update-news + upload-base) + &rest body) + "Set up temporary locations and variables for testing." + (declare (indent 1)) + `(let* ((package-test-user-dir (make-temp-file "pkg-test-user-dir-" t)) + (process-environment (cons (format "HOME=%s" package-test-user-dir) + process-environment)) + (package-user-dir package-test-user-dir) + (package-archives `(("gnu" . ,(or ,location package-test-data-dir)))) + (default-directory package-test-file-dir) + abbreviated-home-dir + package--initialized + package-alist + ,@(if update-news + '(package-update-news-on-upload t) + (list (cl-gensym))) + ,@(if upload-base + '((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t)) + (package-archive-upload-base package-test-archive-upload-base)) + (list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind nil + (let ((buf (get-buffer "*Packages*"))) + (when (buffer-live-p buf) + (kill-buffer buf))) + (unwind-protect + (progn + ,(if basedir `(cd ,basedir)) + (unless (file-directory-p package-user-dir) + (mkdir package-user-dir)) + (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest r) t)) + ((symbol-function 'y-or-n-p) (lambda (&rest r) t))) + ,@(when install + `((package-initialize) + (package-refresh-contents) + (mapc 'package-install ,install))) + (with-temp-buffer + ,(if file + `(insert-file-contents ,file)) + ,@body))) + + (when (file-directory-p package-test-user-dir) + (delete-directory package-test-user-dir t)) + + (when (and (boundp 'package-test-archive-upload-base) + (file-directory-p package-test-archive-upload-base)) + (delete-directory package-test-archive-upload-base t))))) + +(defmacro with-fake-help-buffer (&rest body) + "Execute BODY in a temp buffer which is treated as the \"*Help*\" buffer." + `(with-temp-buffer + (help-mode) + ;; Trick `help-buffer' into using the temp buffer. + (let ((help-xref-following t)) + ,@body))) + +(defun package-test-strip-version (dir) + (replace-regexp-in-string "-pkg\\.el\\'" "" (package--description-file dir))) + +(defun package-test-suffix-matches (base suffix-list) + "Return file names matching BASE concatenated with each item in SUFFIX-LIST" + (cl-mapcan + '(lambda (item) (file-expand-wildcards (concat base item))) + suffix-list)) + +(defvar tar-parse-info) +(declare-function tar-header-name "tar-mode" (cl-x) t) ; defstruct + +(defun package-test-search-tar-file (filename) + "Search the current buffer's `tar-parse-info' variable for FILENAME. + +Must called from within a `tar-mode' buffer." + (cl-dolist (header tar-parse-info) + (let ((tar-name (tar-header-name header))) + (when (string= tar-name filename) + (cl-return t))))) + +(defun package-test-desc-version-string (desc) + "Return the package version as a string." + (package-version-join (package-desc-version desc))) + +(ert-deftest package-test-desc-from-buffer () + "Parse an elisp buffer to get a `package-desc' object." + (with-package-test (:basedir "package-resources" :file "simple-single-1.3.el") + (should (equal (package-buffer-info) simple-single-desc))) + (with-package-test (:basedir "package-resources" :file "simple-depend-1.0.el") + (should (equal (package-buffer-info) simple-depend-desc))) + (with-package-test (:basedir "package-resources" + :file "multi-file-0.2.3.tar") + (tar-mode) + (should (equal (package-tar-file-info) multi-file-desc)))) + +(ert-deftest package-test-install-single () + "Install a single file without using an archive." + (with-package-test (:basedir "package-resources" :file "simple-single-1.3.el") + (should (package-install-from-buffer)) + (package-initialize) + (should (package-installed-p 'simple-single)) + ;; Check if we properly report an "already installed". + (package-install 'simple-single) + (with-current-buffer "*Messages*" + (should (string-match "^[`‘']simple-single[’'] is already installed\n?\\'" + (buffer-string)))) + (should (package-installed-p 'simple-single)) + (let* ((simple-pkg-dir (file-name-as-directory + (expand-file-name + "simple-single-1.3" + package-test-user-dir))) + (autoloads-file (expand-file-name "simple-single-autoloads.el" + simple-pkg-dir))) + (should (file-directory-p simple-pkg-dir)) + (with-temp-buffer + (insert-file-contents (expand-file-name "simple-single-pkg.el" + simple-pkg-dir)) + (should (string= (buffer-string) + (concat ";;; -*- no-byte-compile: t -*-\n" + "(define-package \"simple-single\" \"1.3\" " + "\"A single-file package " + "with no dependencies\" 'nil " + ":authors '((\"J. R. Hacker\" . \"jrh@example.com\")) " + ":maintainer '(\"J. R. Hacker\" . \"jrh@example.com\") " + ":url \"http://doodles.au\"" + ")\n")))) + (should (file-exists-p autoloads-file)) + (should-not (get-file-buffer autoloads-file))))) + +(ert-deftest package-test-install-dependency () + "Install a package which includes a dependency." + (with-package-test () + (package-initialize) + (package-refresh-contents) + (package-install 'simple-depend) + (should (package-installed-p 'simple-single)) + (should (package-installed-p 'simple-depend)))) + +(ert-deftest package-test-macro-compilation () + "Install a package which includes a dependency." + (with-package-test (:basedir "package-resources") + (package-install-file (expand-file-name "macro-problem-package-1.0/")) + (require 'macro-problem) + ;; `macro-problem-func' uses a macro from `macro-aux'. + (should (equal (macro-problem-func) '(progn a b))) + (package-install-file (expand-file-name "macro-problem-package-2.0/")) + ;; After upgrading, `macro-problem-func' depends on a new version + ;; of the macro from `macro-aux'. + (should (equal (macro-problem-func) '(1 b))) + ;; `macro-problem-10-and-90' depends on an entirely new macro from `macro-aux'. + (should (equal (macro-problem-10-and-90) '(10 90))))) + +(ert-deftest package-test-install-two-dependencies () + "Install a package which includes a dependency." + (with-package-test () + (package-initialize) + (package-refresh-contents) + (package-install 'simple-two-depend) + (should (package-installed-p 'simple-single)) + (should (package-installed-p 'simple-depend)) + (should (package-installed-p 'simple-two-depend)))) + +(ert-deftest package-test-refresh-contents () + "Parse an \"archive-contents\" file." + (with-package-test () + (package-initialize) + (package-refresh-contents) + (should (eq 4 (length package-archive-contents))))) + +(ert-deftest package-test-install-single-from-archive () + "Install a single package from a package archive." + (with-package-test () + (package-initialize) + (package-refresh-contents) + (package-install 'simple-single))) + +(ert-deftest package-test-install-prioritized () + "Install a lower version from a higher-prioritized archive." + (with-package-test () + (let* ((newer-version (expand-file-name "package-resources/newer-versions" + package-test-file-dir)) + (package-archives `(("older" . ,package-test-data-dir) + ("newer" . ,newer-version))) + (package-archive-priorities '(("older" . 100)))) + + (package-initialize) + (package-refresh-contents) + (package-install 'simple-single) + + (let ((installed (cadr (assq 'simple-single package-alist)))) + (should (version-list-= '(1 3) + (package-desc-version installed))))))) + +(ert-deftest package-test-install-multifile () + "Check properties of the installed multi-file package." + (with-package-test (:basedir "package-resources" :install '(multi-file)) + (let ((autoload-file + (expand-file-name "multi-file-autoloads.el" + (expand-file-name + "multi-file-0.2.3" + package-test-user-dir))) + (installed-files '("dir" "multi-file.info" "multi-file-sub.elc" + "multi-file-autoloads.el" "multi-file.elc")) + (autoload-forms '("^(defvar multi-file-custom-var" + "^(custom-autoload 'multi-file-custom-var" + "^(autoload 'multi-file-mode")) + (pkg-dir (file-name-as-directory + (expand-file-name + "multi-file-0.2.3" + package-test-user-dir)))) + (package-refresh-contents) + (should (package-installed-p 'multi-file)) + (with-temp-buffer + (insert-file-contents-literally autoload-file) + (dolist (fn installed-files) + (should (file-exists-p (expand-file-name fn pkg-dir)))) + (dolist (re autoload-forms) + (goto-char (point-min)) + (should (re-search-forward re nil t))))))) + +(ert-deftest package-test-update-listing () + "Ensure installed package status is updated." + (with-package-test () + (let ((buf (package-list-packages))) + (search-forward-regexp "^ +simple-single") + (package-menu-mark-install) + (package-menu-execute) + (run-hooks 'post-command-hook) + (should (package-installed-p 'simple-single)) + (switch-to-buffer "*Packages*") + (goto-char (point-min)) + (should (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+installed" nil t)) + (goto-char (point-min)) + (should-not (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+\\(available\\|new\\)" nil t)) + (kill-buffer buf)))) + +(ert-deftest package-test-update-archives () + "Test updating package archives." + (with-package-test () + (let ((buf (package-list-packages))) + (package-menu-refresh) + (search-forward-regexp "^ +simple-single") + (package-menu-mark-install) + (package-menu-execute) + (should (package-installed-p 'simple-single)) + (let ((package-test-data-dir + (expand-file-name "package-resources/newer-versions" package-test-file-dir))) + (setq package-archives `(("gnu" . ,package-test-data-dir))) + (package-menu-refresh) + + ;; New version should be available and old version should be installed + (goto-char (point-min)) + (should (re-search-forward "^\\s-+simple-single\\s-+1.4\\s-+available" nil t)) + (should (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+installed" nil t)) + + (goto-char (point-min)) + (should (re-search-forward "^\\s-+new-pkg\\s-+1.0\\s-+\\(available\\|new\\)" nil t)) + + (package-menu-mark-upgrades) + (package-menu-execute) + (package-menu-refresh) + (should (package-installed-p 'simple-single '(1 4))))))) + +(ert-deftest package-test-update-archives-async () + "Test updating package archives asynchronously." + (skip-unless (executable-find "python2")) + (let* ((package-menu-async t) + (default-directory package-test-data-dir) + (process (start-process + "package-server" "package-server-buffer" + (executable-find "python2") + "package-test-server.py")) + port) + (unwind-protect + (progn + (with-current-buffer "package-server-buffer" + (should + (with-timeout (10 nil) + (while (not port) + (accept-process-output nil 1) + (goto-char (point-min)) + (if (re-search-forward "Serving HTTP on .* port \\([0-9]+\\) " + nil t) + (setq port (match-string 1)))) + port))) + (with-package-test (:basedir + package-test-data-dir + :location (format "http://0.0.0.0:%s/" port)) + (list-packages) + (should package--downloads-in-progress) + (should mode-line-process) + (should-not + (with-timeout (10 'timeout) + (while package--downloads-in-progress + (accept-process-output nil 1)) + nil)) + ;; If the server process died, there's some non-Emacs problem. + ;; Eg maybe the port was already in use. + (skip-unless (process-live-p process)) + (goto-char (point-min)) + (should + (search-forward-regexp "^ +simple-single" nil t)))) + (if (process-live-p process) (kill-process process))))) + +(ert-deftest package-test-describe-package () + "Test displaying help for a package." + + (require 'finder-inf) + ;; Built-in + (with-fake-help-buffer + (describe-package '5x5) + (goto-char (point-min)) + (should (search-forward "5x5 is a built-in package." nil t)) + ;; Don't assume the descriptions are in any particular order. + (save-excursion (should (search-forward "Status: Built-in." nil t))) + (save-excursion (should (search-forward "Summary: simple little puzzle game" nil t))) + (should (search-forward "The aim of 5x5" nil t))) + + ;; Installed + (with-package-test () + (package-initialize) + (package-refresh-contents) + (package-install 'simple-single) + (with-fake-help-buffer + (describe-package 'simple-single) + (goto-char (point-min)) + (should (search-forward "simple-single is an installed package." nil t)) + (save-excursion (should (re-search-forward "Status: Installed in ['`‘]simple-single-1.3/['’] (unsigned)." nil t))) + (save-excursion (should (search-forward "Version: 1.3" nil t))) + (save-excursion (should (search-forward "Summary: A single-file package with no dependencies" nil t))) + (save-excursion (should (search-forward "Homepage: http://doodles.au" nil t))) + (save-excursion (should (re-search-forward "Keywords: \\[?frobnicate\\]?" nil t))) + ;; No description, though. Because at this point we don't know + ;; what archive the package originated from, and we don't have + ;; its readme file saved. + ))) + +(ert-deftest package-test-describe-non-installed-package () + "Test displaying of the readme for non-installed package." + + (with-package-test () + (package-initialize) + (package-refresh-contents) + (with-fake-help-buffer + (describe-package 'simple-single) + (goto-char (point-min)) + (should (search-forward "Homepage: http://doodles.au" nil t)) + (should (search-forward "This package provides a minor mode to frobnicate" + nil t))))) + +(ert-deftest package-test-describe-non-installed-multi-file-package () + "Test displaying of the readme for non-installed multi-file package." + + (with-package-test () + (package-initialize) + (package-refresh-contents) + (with-fake-help-buffer + (describe-package 'multi-file) + (goto-char (point-min)) + (should (search-forward "Homepage: http://puddles.li" nil t)) + (should (search-forward "This is a bare-bones readme file for the multi-file" + nil t))))) + +(ert-deftest package-test-signed () + "Test verifying package signature." + (skip-unless (ignore-errors + (let ((homedir (make-temp-file "package-test" t))) + (unwind-protect + (let ((process-environment + (cons (format "HOME=%s" homedir) + process-environment))) + (epg-check-configuration (epg-configuration)) + (epg-find-configuration 'OpenPGP)) + (delete-directory homedir t))))) + (let* ((keyring (expand-file-name "key.pub" package-test-data-dir)) + (package-test-data-dir + (expand-file-name "package-resources/signed" package-test-file-dir))) + (with-package-test () + (package-initialize) + (package-import-keyring keyring) + (package-refresh-contents) + (let ((package-check-signature 'allow-unsigned)) + (should (package-install 'signed-good)) + (should-error (package-install 'signed-bad))) + (let ((package-check-signature t)) + (should (package-install 'signed-good)) + (should-error (package-install 'signed-bad))) + (let ((package-check-signature nil)) + (should (package-install 'signed-good)) + (should (package-install 'signed-bad))) + ;; Check if the installed package status is updated. + (let ((buf (package-list-packages))) + (package-menu-refresh) + (should (re-search-forward + "^\\s-+signed-good\\s-+\\(\\S-+\\)\\s-+\\(\\S-+\\)\\s-" + nil t)) + (should (string-equal (match-string-no-properties 1) "1.0")) + (should (string-equal (match-string-no-properties 2) "installed"))) + ;; Check if the package description is updated. + (with-fake-help-buffer + (describe-package 'signed-good) + (goto-char (point-min)) + (should (re-search-forward "signed-good is an? \\(\\S-+\\) package." nil t)) + (should (string-equal (match-string-no-properties 1) "installed")) + (should (re-search-forward + "Status: Installed in ['`‘]signed-good-1.0/['’]." + nil t)))))) + + + +;;; Tests for package-x features. + +(require 'package-x) + +(defvar package-x-test--single-archive-entry-1-3 + (cons 'simple-single + (package-make-ac-desc '(1 3) nil + "A single-file package with no dependencies" + 'single + '((:authors ("J. R. Hacker" . "jrh@example.com")) + (:maintainer "J. R. Hacker" . "jrh@example.com") + (:url . "http://doodles.au")))) + "Expected contents of the archive entry from the \"simple-single\" package.") + +(defvar package-x-test--single-archive-entry-1-4 + (cons 'simple-single + (package-make-ac-desc '(1 4) nil + "A single-file package with no dependencies" + 'single + '((:authors ("J. R. Hacker" . "jrh@example.com")) + (:maintainer "J. R. Hacker" . "jrh@example.com")))) + "Expected contents of the archive entry from the updated \"simple-single\" package.") + +(ert-deftest package-x-test-upload-buffer () + "Test creating an \"archive-contents\" file" + (with-package-test (:basedir "package-resources" + :file "simple-single-1.3.el" + :upload-base t) + (package-upload-buffer) + (should (file-exists-p (expand-file-name "archive-contents" + package-archive-upload-base))) + (should (file-exists-p (expand-file-name "simple-single-1.3.el" + package-archive-upload-base))) + (should (file-exists-p (expand-file-name "simple-single-readme.txt" + package-archive-upload-base))) + + (let (archive-contents) + (with-temp-buffer + (insert-file-contents + (expand-file-name "archive-contents" + package-archive-upload-base)) + (setq archive-contents + (package-read-from-string + (buffer-substring (point-min) (point-max))))) + (should (equal archive-contents + (list 1 package-x-test--single-archive-entry-1-3)))))) + +(ert-deftest package-x-test-upload-new-version () + "Test uploading a new version of a package" + (with-package-test (:basedir "package-resources" + :file "simple-single-1.3.el" + :upload-base t) + (package-upload-buffer) + (with-temp-buffer + (insert-file-contents "newer-versions/simple-single-1.4.el") + (package-upload-buffer)) + + (let (archive-contents) + (with-temp-buffer + (insert-file-contents + (expand-file-name "archive-contents" + package-archive-upload-base)) + (setq archive-contents + (package-read-from-string + (buffer-substring (point-min) (point-max))))) + (should (equal archive-contents + (list 1 package-x-test--single-archive-entry-1-4)))))) + +(ert-deftest package-test-get-deps () + "Test `package--get-deps' with complex structures." + (let ((package-alist + (mapcar (lambda (p) (list (package-desc-name p) p)) + (list simple-single-desc + simple-depend-desc + multi-file-desc + new-pkg-desc + simple-depend-desc-1 + simple-depend-desc-2)))) + (should + (equal (package--get-deps 'simple-depend) + '(simple-single))) + (should + (equal (package--get-deps 'simple-depend 'indirect) + nil)) + (should + (equal (package--get-deps 'simple-depend 'direct) + '(simple-single))) + (should + (equal (package--get-deps 'simple-depend-2) + '(simple-depend-1 multi-file simple-depend simple-single))) + (should + (equal (package--get-deps 'simple-depend-2 'indirect) + '(simple-depend multi-file simple-single))) + (should + (equal (package--get-deps 'simple-depend-2 'direct) + '(simple-depend-1 multi-file))))) + +(ert-deftest package-test-sort-by-dependence () + "Test `package--sort-by-dependence' with complex structures." + (let ((package-alist + (mapcar (lambda (p) (list (package-desc-name p) p)) + (list simple-single-desc + simple-depend-desc + multi-file-desc + new-pkg-desc + simple-depend-desc-1 + simple-depend-desc-2))) + (delete-list + (list simple-single-desc + simple-depend-desc + multi-file-desc + new-pkg-desc + simple-depend-desc-1 + simple-depend-desc-2))) + (should + (equal (package--sort-by-dependence delete-list) + + (list simple-depend-desc-2 simple-depend-desc-1 new-pkg-desc + multi-file-desc simple-depend-desc simple-single-desc))) + (should + (equal (package--sort-by-dependence (reverse delete-list)) + (list new-pkg-desc simple-depend-desc-2 simple-depend-desc-1 + multi-file-desc simple-depend-desc simple-single-desc))))) + +(provide 'package-test) + +;;; package-test.el ends here diff --cc test/lisp/emacs-lisp/pcase-tests.el index a428e4092f1,00000000000..ef0b2f6b246 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@@ -1,74 -1,0 +1,74 @@@ +;;; pcase-tests.el --- Test suite for pcase macro. + - ;; Copyright (C) 2012-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2012-2017 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(ert-deftest pcase-tests-base () + "Test pcase code." + (should (equal (pcase '(1 . 2) ((app car '2) 6) ((app car '1) 5)) 5))) + +(ert-deftest pcase-tests-bugs () + (should (equal (pcase '(2 . 3) ;bug#18554 + (`(,hd . ,(and (pred atom) tl)) (list hd tl)) + ((pred consp) nil)) + '(2 3)))) + +(pcase-defmacro pcase-tests-plus (pat n) + `(app (lambda (v) (- v ,n)) ,pat)) + +(ert-deftest pcase-tests-macro () + (should (equal (pcase 5 ((pcase-tests-plus x 3) x)) 2))) + +(defun pcase-tests-grep (fname exp) + (when (consp exp) + (or (eq fname (car exp)) + (cl-some (lambda (exp) (pcase-tests-grep fname exp)) (cdr exp))))) + +(ert-deftest pcase-tests-tests () + (should (pcase-tests-grep 'memq '(or (+ 2 3) (memq x y)))) + (should-not (pcase-tests-grep 'memq '(or (+ 2 3) (- x y))))) + +(ert-deftest pcase-tests-member () + (should (pcase-tests-grep + 'memq (macroexpand-all '(pcase x ((or 1 2 3) body))))) + (should (pcase-tests-grep + 'member (macroexpand-all '(pcase x ((or '"a" '2 '3) body))))) + (should-not (pcase-tests-grep + 'memq (macroexpand-all '(pcase x ((or "a" 2 3) body))))) + (let ((exp (macroexpand-all + '(pcase x + ("a" body1) + (2 body2) + ((or "a" 2 3) body))))) + (should-not (pcase-tests-grep 'memq exp)) + (should-not (pcase-tests-grep 'member exp)))) + +(ert-deftest pcase-tests-vectors () + (should (equal (pcase [1 2] (`[,x] 1) (`[,x ,y] (+ x y))) 3))) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +;;; pcase-tests.el ends here. diff --cc test/lisp/emacs-lisp/regexp-opt-tests.el index 01119a3374f,00000000000..92626317052 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/regexp-opt-tests.el +++ b/test/lisp/emacs-lisp/regexp-opt-tests.el @@@ -1,33 -1,0 +1,33 @@@ +;;; regexp-tests.el --- Test suite for regular expression handling. + - ;; Copyright (C) 2013-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Keywords: internal +;; Human-Keywords: internal + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'regexp-opt) + +(ert-deftest regexp-test-regexp-opt () + "Test the `compilation-error-regexp-alist' regexps. +The test data is in `compile-tests--test-regexps-data'." + (should (string-match (regexp-opt-charset '(?^)) "a^b"))) + +;;; regexp-tests.el ends here. diff --cc test/lisp/emacs-lisp/seq-tests.el index a7a43471de3,00000000000..788524bedb5 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/seq-tests.el +++ b/test/lisp/emacs-lisp/seq-tests.el @@@ -1,403 -1,0 +1,403 @@@ +;;; seq-tests.el --- Tests for sequences.el + - ;; Copyright (C) 2014-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2014-2017 Free Software Foundation, Inc. + +;; Author: Nicolas Petton +;; Maintainer: emacs-devel@gnu.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Tests for sequences.el + +;;; Code: + +(require 'ert) +(require 'seq) + +(defmacro with-test-sequences (spec &rest body) + "Successively bind VAR to a list, vector, and string built from SEQ. +Evaluate BODY for each created sequence. + +\(fn (var seq) body)" + (declare (indent 1) (debug ((symbolp form) body))) + (let ((initial-seq (make-symbol "initial-seq"))) + `(let ((,initial-seq ,(cadr spec))) + ,@(mapcar (lambda (s) + `(let ((,(car spec) (apply (function ,s) ,initial-seq))) + ,@body)) + '(list vector string))))) + +(defun same-contents-p (seq1 seq2) + "Return t if SEQ1 and SEQ2 have the same contents, nil otherwise." + (equal (append seq1 '()) (append seq2 '()))) + +(defun test-sequences-evenp (integer) + "Return t if INTEGER is even." + (eq (logand integer 1) 0)) + +(defun test-sequences-oddp (integer) + "Return t if INTEGER is odd." + (not (test-sequences-evenp integer))) + +(ert-deftest test-setf-seq-elt () + (with-test-sequences (seq '(1 2 3)) + (setf (seq-elt seq 1) 4) + (should (= 4 (seq-elt seq 1))))) + +(ert-deftest test-seq-drop () + (with-test-sequences (seq '(1 2 3 4)) + (should (equal (seq-drop seq 0) seq)) + (should (equal (seq-drop seq 1) (seq-subseq seq 1))) + (should (equal (seq-drop seq 2) (seq-subseq seq 2))) + (should (seq-empty-p (seq-drop seq 4))) + (should (seq-empty-p (seq-drop seq 10)))) + (with-test-sequences (seq '()) + (should (seq-empty-p (seq-drop seq 0))) + (should (seq-empty-p (seq-drop seq 1))))) + +(ert-deftest test-seq-take () + (with-test-sequences (seq '(2 3 4 5)) + (should (seq-empty-p (seq-take seq 0))) + (should (= (seq-length (seq-take seq 1)) 1)) + (should (= (seq-elt (seq-take seq 1) 0) 2)) + (should (same-contents-p (seq-take seq 3) '(2 3 4))) + (should (equal (seq-take seq 10) seq)))) + +(ert-deftest test-seq-drop-while () + (with-test-sequences (seq '(1 3 2 4)) + (should (equal (seq-drop-while #'test-sequences-oddp seq) + (seq-drop seq 2))) + (should (equal (seq-drop-while #'test-sequences-evenp seq) + seq)) + (should (seq-empty-p (seq-drop-while #'numberp seq)))) + (with-test-sequences (seq '()) + (should (seq-empty-p (seq-drop-while #'test-sequences-oddp seq))))) + +(ert-deftest test-seq-take-while () + (with-test-sequences (seq '(1 3 2 4)) + (should (equal (seq-take-while #'test-sequences-oddp seq) + (seq-take seq 2))) + (should (seq-empty-p (seq-take-while #'test-sequences-evenp seq))) + (should (equal (seq-take-while #'numberp seq) seq))) + (with-test-sequences (seq '()) + (should (seq-empty-p (seq-take-while #'test-sequences-oddp seq))))) + +(ert-deftest test-seq-map-indexed () + (should (equal (seq-map-indexed (lambda (elt i) + (list elt i)) + nil) + nil)) + (should (equal (seq-map-indexed (lambda (elt i) + (list elt i)) + '(a b c d)) + '((a 0) (b 1) (c 2) (d 3))))) + +(ert-deftest test-seq-do-indexed () + (let ((result nil)) + (seq-do-indexed (lambda (elt i) + (add-to-list 'result (list elt i))) + nil) + (should (equal result nil))) + (with-test-sequences (seq '(4 5 6)) + (let ((result nil)) + (seq-do-indexed (lambda (elt i) + (add-to-list 'result (list elt i))) + seq) + (should (equal (seq-elt result 0) '(6 2))) + (should (equal (seq-elt result 1) '(5 1))) + (should (equal (seq-elt result 2) '(4 0)))))) + +(ert-deftest test-seq-filter () + (with-test-sequences (seq '(6 7 8 9 10)) + (should (equal (seq-filter #'test-sequences-evenp seq) '(6 8 10))) + (should (equal (seq-filter #'test-sequences-oddp seq) '(7 9))) + (should (equal (seq-filter (lambda (elt) nil) seq) '()))) + (with-test-sequences (seq '()) + (should (equal (seq-filter #'test-sequences-evenp seq) '())))) + +(ert-deftest test-seq-remove () + (with-test-sequences (seq '(6 7 8 9 10)) + (should (equal (seq-remove #'test-sequences-evenp seq) '(7 9))) + (should (equal (seq-remove #'test-sequences-oddp seq) '(6 8 10))) + (should (same-contents-p (seq-remove (lambda (elt) nil) seq) seq))) + (with-test-sequences (seq '()) + (should (equal (seq-remove #'test-sequences-evenp seq) '())))) + +(ert-deftest test-seq-count () + (with-test-sequences (seq '(6 7 8 9 10)) + (should (equal (seq-count #'test-sequences-evenp seq) 3)) + (should (equal (seq-count #'test-sequences-oddp seq) 2)) + (should (equal (seq-count (lambda (elt) nil) seq) 0))) + (with-test-sequences (seq '()) + (should (equal (seq-count #'test-sequences-evenp seq) 0)))) + +(ert-deftest test-seq-reduce () + (with-test-sequences (seq '(1 2 3 4)) + (should (= (seq-reduce #'+ seq 0) 10)) + (should (= (seq-reduce #'+ seq 5) 15))) + (with-test-sequences (seq '()) + (should (eq (seq-reduce #'+ seq 0) 0)) + (should (eq (seq-reduce #'+ seq 7) 7)))) + +(ert-deftest test-seq-some () + (with-test-sequences (seq '(4 3 2 1)) + (should (seq-some #'test-sequences-evenp seq)) + (should (seq-some #'test-sequences-oddp seq)) + (should-not (seq-some (lambda (elt) (> elt 10)) seq))) + (with-test-sequences (seq '()) + (should-not (seq-some #'test-sequences-oddp seq))) + (should (seq-some #'null '(1 nil 2)))) + +(ert-deftest test-seq-find () + (with-test-sequences (seq '(4 3 2 1)) + (should (= 4 (seq-find #'test-sequences-evenp seq))) + (should (= 3 (seq-find #'test-sequences-oddp seq))) + (should-not (seq-find (lambda (elt) (> elt 10)) seq))) + (should-not (seq-find #'null '(1 nil 2))) + (should-not (seq-find #'null '(1 nil 2) t)) + (should-not (seq-find #'null '(1 2 3))) + (should (seq-find #'null '(1 2 3) 'sentinel))) + +(ert-deftest test-seq-contains () + (with-test-sequences (seq '(3 4 5 6)) + (should (seq-contains seq 3)) + (should-not (seq-contains seq 7))) + (with-test-sequences (seq '()) + (should-not (seq-contains seq 3)) + (should-not (seq-contains seq nil)))) + +(ert-deftest test-seq-contains-should-return-the-elt () + (with-test-sequences (seq '(3 4 5 6)) + (should (= 5 (seq-contains seq 5))))) + +(ert-deftest test-seq-every-p () + (with-test-sequences (seq '(43 54 22 1)) + (should (seq-every-p (lambda (elt) t) seq)) + (should-not (seq-every-p #'test-sequences-oddp seq)) + (should-not (seq-every-p #'test-sequences-evenp seq))) + (with-test-sequences (seq '(42 54 22 2)) + (should (seq-every-p #'test-sequences-evenp seq)) + (should-not (seq-every-p #'test-sequences-oddp seq))) + (with-test-sequences (seq '()) + (should (seq-every-p #'identity seq)) + (should (seq-every-p #'test-sequences-evenp seq)))) + +(ert-deftest test-seq-empty-p () + (with-test-sequences (seq '(0)) + (should-not (seq-empty-p seq))) + (with-test-sequences (seq '(0 1 2)) + (should-not (seq-empty-p seq))) + (with-test-sequences (seq '()) + (should (seq-empty-p seq)))) + +(ert-deftest test-seq-sort () + (should (equal (seq-sort #'< "cbaf") "abcf")) + (should (equal (seq-sort #'< '(2 1 9 4)) '(1 2 4 9))) + (should (equal (seq-sort #'< [2 1 9 4]) [1 2 4 9])) + (should (equal (seq-sort #'< "") ""))) + +(ert-deftest test-seq-uniq () + (with-test-sequences (seq '(2 4 6 8 6 4 3)) + (should (equal (seq-uniq seq) '(2 4 6 8 3)))) + (with-test-sequences (seq '(3 3 3 3 3)) + (should (equal (seq-uniq seq) '(3)))) + (with-test-sequences (seq '()) + (should (equal (seq-uniq seq) '())))) + +(ert-deftest test-seq-subseq () + (with-test-sequences (seq '(2 3 4 5)) + (should (equal (seq-subseq seq 0 4) seq)) + (should (same-contents-p (seq-subseq seq 2 4) '(4 5))) + (should (same-contents-p (seq-subseq seq 1 3) '(3 4))) + (should (same-contents-p (seq-subseq seq 1 -1) '(3 4)))) + (should (vectorp (seq-subseq [2 3 4 5] 2))) + (should (stringp (seq-subseq "foo" 2 3))) + (should (listp (seq-subseq '(2 3 4 4) 2 3))) + (should-error (seq-subseq '(1 2 3) 4)) + (should-not (seq-subseq '(1 2 3) 3)) + (should (seq-subseq '(1 2 3) -3)) + (should-error (seq-subseq '(1 2 3) 1 4)) + (should (seq-subseq '(1 2 3) 1 3)) + (should-error (seq-subseq '() -1)) + (should-error (seq-subseq [] -1)) + (should-error (seq-subseq "" -1)) + (should-not (seq-subseq '() 0)) + (should-error (seq-subseq '() 0 -1))) + +(ert-deftest test-seq-concatenate () + (with-test-sequences (seq '(2 4 6)) + (should (equal (seq-concatenate 'string seq [8]) (string 2 4 6 8))) + (should (equal (seq-concatenate 'list seq '(8 10)) '(2 4 6 8 10))) + (should (equal (seq-concatenate 'vector seq '(8 10)) [2 4 6 8 10])) + (should (equal (seq-concatenate 'vector nil '(8 10)) [8 10])) + (should (equal (seq-concatenate 'vector seq nil) [2 4 6])))) + +(ert-deftest test-seq-mapcat () + (should (equal (seq-mapcat #'seq-reverse '((3 2 1) (6 5 4))) + '(1 2 3 4 5 6))) + (should (equal (seq-mapcat #'seq-reverse '[(3 2 1) (6 5 4)]) + '(1 2 3 4 5 6))) + (should (equal (seq-mapcat #'seq-reverse '((3 2 1) (6 5 4)) 'vector) + '[1 2 3 4 5 6]))) + +(ert-deftest test-seq-partition () + (should (same-contents-p (seq-partition '(0 1 2 3 4 5 6 7) 3) + '((0 1 2) (3 4 5) (6 7)))) + (should (same-contents-p (seq-partition '[0 1 2 3 4 5 6 7] 3) + '([0 1 2] [3 4 5] [6 7]))) + (should (same-contents-p (seq-partition "Hello world" 2) + '("He" "ll" "o " "wo" "rl" "d"))) + (should (equal (seq-partition '() 2) '())) + (should (equal (seq-partition '(1 2 3) -1) '()))) + +(ert-deftest test-seq-group-by () + (with-test-sequences (seq '(1 2 3 4)) + (should (equal (seq-group-by #'test-sequences-oddp seq) + '((t 1 3) (nil 2 4))))) + (should (equal (seq-group-by #'car '((a 1) (b 3) (c 4) (a 2))) + '((b (b 3)) (c (c 4)) (a (a 1) (a 2)))))) + +(ert-deftest test-seq-reverse () + (with-test-sequences (seq '(1 2 3 4)) + (should (same-contents-p (seq-reverse seq) '(4 3 2 1))) + (should (equal (type-of (seq-reverse seq)) + (type-of seq))))) + +(ert-deftest test-seq-into () + (let* ((vector [1 2 3]) + (list (seq-into vector 'list))) + (should (same-contents-p vector list)) + (should (listp list))) + (let* ((list '(hello world)) + (vector (seq-into list 'vector))) + (should (same-contents-p vector list)) + (should (vectorp vector))) + (let* ((string "hello") + (list (seq-into string 'list))) + (should (same-contents-p string list)) + (should (stringp string))) + (let* ((string "hello") + (vector (seq-into string 'vector))) + (should (same-contents-p string vector)) + (should (stringp string))) + (let* ((list nil) + (vector (seq-into list 'vector))) + (should (same-contents-p list vector)) + (should (vectorp vector)))) + +(ert-deftest test-seq-intersection () + (let ((v1 [2 3 4 5]) + (v2 [1 3 5 6 7])) + (should (same-contents-p (seq-intersection v1 v2) + '(3 5)))) + (let ((l1 '(2 3 4 5)) + (l2 '(1 3 5 6 7))) + (should (same-contents-p (seq-intersection l1 l2) + '(3 5)))) + (let ((v1 [2 4 6]) + (v2 [1 3 5])) + (should (seq-empty-p (seq-intersection v1 v2))))) + +(ert-deftest test-seq-difference () + (let ((v1 [2 3 4 5]) + (v2 [1 3 5 6 7])) + (should (same-contents-p (seq-difference v1 v2) + '(2 4)))) + (let ((l1 '(2 3 4 5)) + (l2 '(1 3 5 6 7))) + (should (same-contents-p (seq-difference l1 l2) + '(2 4)))) + (let ((v1 [2 4 6]) + (v2 [2 4 6])) + (should (seq-empty-p (seq-difference v1 v2))))) + +(ert-deftest test-seq-let () + (with-test-sequences (seq '(1 2 3 4)) + (seq-let (a b c d e) seq + (should (= a 1)) + (should (= b 2)) + (should (= c 3)) + (should (= d 4)) + (should (null e))) + (seq-let (a b &rest others) seq + (should (= a 1)) + (should (= b 2)) + (should (same-contents-p others (seq-drop seq 2))))) + (let ((seq '(1 (2 (3 (4)))))) + (seq-let (_ (_ (_ (a)))) seq + (should (= a 4)))) + (let (seq) + (seq-let (a b c) seq + (should (null a)) + (should (null b)) + (should (null c))))) + +(ert-deftest test-seq-min-max () + (with-test-sequences (seq '(4 5 3 2 0 4)) + (should (= (seq-min seq) 0)) + (should (= (seq-max seq) 5)))) + +(ert-deftest test-seq-into-sequence () + (with-test-sequences (seq '(1 2 3)) + (should (eq seq (seq-into-sequence seq))) + (should-error (seq-into-sequence 2)))) + +(ert-deftest test-seq-position () + (with-test-sequences (seq '(2 4 6)) + (should (null (seq-position seq 1))) + (should (= (seq-position seq 4) 1))) + (let ((seq '(a b c))) + (should (null (seq-position seq 'd #'eq))) + (should (= (seq-position seq 'a #'eq) 0)) + (should (null (seq-position seq (make-symbol "a") #'eq))))) + +(ert-deftest test-seq-sort-by () + (let ((seq ["x" "xx" "xxx"])) + (should (equal (seq-sort-by #'seq-length #'> seq) + ["xxx" "xx" "x"])))) + +(ert-deftest test-seq-random-elt-take-all () + (let ((seq '(a b c d e)) + (elts '())) + (should (= 0 (length elts))) + (dotimes (_ 1000) + (let ((random-elt (seq-random-elt seq))) + (add-to-list 'elts + random-elt))) + (should (= 5 (length elts))))) + +(ert-deftest test-seq-random-elt-signal-on-empty () + (should-error (seq-random-elt nil)) + (should-error (seq-random-elt [])) + (should-error (seq-random-elt ""))) + +(ert-deftest test-seq-mapn-circular-lists () + (let ((l1 '#1=(1 . #1#))) + (should (equal (seq-mapn #'+ '(3 4 5 7) l1) + '(4 5 6 8))))) + +(ert-deftest test-seq-into-and-identity () + (let ((lst '(1 2 3)) + (vec [1 2 3]) + (str "foo bar")) + (should (eq (seq-into lst 'list) lst)) + (should (eq (seq-into vec 'vector) vec)) + (should (eq (seq-into str 'string) str)))) + +(provide 'seq-tests) +;;; seq-tests.el ends here diff --cc test/lisp/emacs-lisp/subr-x-tests.el index e30b5d8f549,00000000000..2b2a5cd0d71 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@@ -1,526 -1,0 +1,526 @@@ +;;; subr-x-tests.el --- Testing the extended lisp routines + - ;; Copyright (C) 2014-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2014-2017 Free Software Foundation, Inc. + +;; Author: Fabián E. Gallina +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'subr-x) + + +;; if-let tests + +(ert-deftest subr-x-test-if-let-single-binding-expansion () + "Test single bindings are expanded properly." + (should (equal + (macroexpand + '(if-let (a 1) + (- a) + "no")) + '(let* ((a (and t 1))) + (if a + (- a) + "no")))) + (should (equal + (macroexpand + '(if-let (a) + (- a) + "no")) + '(let* ((a (and t nil))) + (if a + (- a) + "no"))))) + +(ert-deftest subr-x-test-if-let-single-symbol-expansion () + "Test single symbol bindings are expanded properly." + (should (equal + (macroexpand + '(if-let (a) + (- a) + "no")) + '(let* ((a (and t nil))) + (if a + (- a) + "no")))) + (should (equal + (macroexpand + '(if-let (a b c) + (- a) + "no")) + '(let* ((a (and t nil)) + (b (and a nil)) + (c (and b nil))) + (if c + (- a) + "no")))) + (should (equal + (macroexpand + '(if-let (a (b 2) c) + (- a) + "no")) + '(let* ((a (and t nil)) + (b (and a 2)) + (c (and b nil))) + (if c + (- a) + "no"))))) + +(ert-deftest subr-x-test-if-let-nil-related-expansion () + "Test nil is processed properly." + (should (equal + (macroexpand + '(if-let (nil) + (- a) + "no")) + '(let* ((nil (and t nil))) + (if nil + (- a) + "no")))) + (should (equal + (macroexpand + '(if-let ((nil)) + (- a) + "no")) + '(let* ((nil (and t nil))) + (if nil + (- a) + "no")))) + (should (equal + (macroexpand + '(if-let ((a 1) (nil) (b 2)) + (- a) + "no")) + '(let* ((a (and t 1)) + (nil (and a nil)) + (b (and nil 2))) + (if b + (- a) + "no")))) + (should (equal + (macroexpand + '(if-let ((a 1) nil (b 2)) + (- a) + "no")) + '(let* ((a (and t 1)) + (nil (and a nil)) + (b (and nil 2))) + (if b + (- a) + "no"))))) + +(ert-deftest subr-x-test-if-let-malformed-binding () + "Test malformed bindings trigger errors." + (should-error (macroexpand + '(if-let (_ (a 1 1) (b 2) (c 3) d) + (- a) + "no")) + :type 'error) + (should-error (macroexpand + '(if-let (_ (a 1) (b 2 2) (c 3) d) + (- a) + "no")) + :type 'error) + (should-error (macroexpand + '(if-let (_ (a 1) (b 2) (c 3 3) d) + (- a) + "no")) + :type 'error) + (should-error (macroexpand + '(if-let ((a 1 1)) + (- a) + "no")) + :type 'error)) + +(ert-deftest subr-x-test-if-let-true () + "Test `if-let' with truthy bindings." + (should (equal + (if-let (a 1) + a + "no") + 1)) + (should (equal + (if-let ((a 1) (b 2) (c 3)) + (list a b c) + "no") + (list 1 2 3)))) + +(ert-deftest subr-x-test-if-let-false () + "Test `if-let' with falsie bindings." + (should (equal + (if-let (a nil) + (list a b c) + "no") + "no")) + (should (equal + (if-let ((a nil) (b 2) (c 3)) + (list a b c) + "no") + "no")) + (should (equal + (if-let ((a 1) (b nil) (c 3)) + (list a b c) + "no") + "no")) + (should (equal + (if-let ((a 1) (b 2) (c nil)) + (list a b c) + "no") + "no")) + (should (equal + (if-let (z (a 1) (b 2) (c 3)) + (list a b c) + "no") + "no")) + (should (equal + (if-let ((a 1) (b 2) (c 3) d) + (list a b c) + "no") + "no"))) + +(ert-deftest subr-x-test-if-let-bound-references () + "Test `if-let' bindings can refer to already bound symbols." + (should (equal + (if-let ((a (1+ 0)) (b (1+ a)) (c (1+ b))) + (list a b c) + "no") + (list 1 2 3)))) + +(ert-deftest subr-x-test-if-let-and-laziness-is-preserved () + "Test `if-let' respects `and' laziness." + (let (a-called b-called c-called) + (should (equal + (if-let ((a nil) + (b (setq b-called t)) + (c (setq c-called t))) + "yes" + (list a-called b-called c-called)) + (list nil nil nil)))) + (let (a-called b-called c-called) + (should (equal + (if-let ((a (setq a-called t)) + (b nil) + (c (setq c-called t))) + "yes" + (list a-called b-called c-called)) + (list t nil nil)))) + (let (a-called b-called c-called) + (should (equal + (if-let ((a (setq a-called t)) + (b (setq b-called t)) + (c nil) + (d (setq c-called t))) + "yes" + (list a-called b-called c-called)) + (list t t nil))))) + + +;; when-let tests + +(ert-deftest subr-x-test-when-let-body-expansion () + "Test body allows for multiple sexps wrapping with progn." + (should (equal + (macroexpand + '(when-let (a 1) + (message "opposite") + (- a))) + '(let* ((a (and t 1))) + (if a + (progn + (message "opposite") + (- a))))))) + +(ert-deftest subr-x-test-when-let-single-binding-expansion () + "Test single bindings are expanded properly." + (should (equal + (macroexpand + '(when-let (a 1) + (- a))) + '(let* ((a (and t 1))) + (if a + (- a))))) + (should (equal + (macroexpand + '(when-let (a) + (- a))) + '(let* ((a (and t nil))) + (if a + (- a)))))) + +(ert-deftest subr-x-test-when-let-single-symbol-expansion () + "Test single symbol bindings are expanded properly." + (should (equal + (macroexpand + '(when-let (a) + (- a))) + '(let* ((a (and t nil))) + (if a + (- a))))) + (should (equal + (macroexpand + '(when-let (a b c) + (- a))) + '(let* ((a (and t nil)) + (b (and a nil)) + (c (and b nil))) + (if c + (- a))))) + (should (equal + (macroexpand + '(when-let (a (b 2) c) + (- a))) + '(let* ((a (and t nil)) + (b (and a 2)) + (c (and b nil))) + (if c + (- a)))))) + +(ert-deftest subr-x-test-when-let-nil-related-expansion () + "Test nil is processed properly." + (should (equal + (macroexpand + '(when-let (nil) + (- a))) + '(let* ((nil (and t nil))) + (if nil + (- a))))) + (should (equal + (macroexpand + '(when-let ((nil)) + (- a))) + '(let* ((nil (and t nil))) + (if nil + (- a))))) + (should (equal + (macroexpand + '(when-let ((a 1) (nil) (b 2)) + (- a))) + '(let* ((a (and t 1)) + (nil (and a nil)) + (b (and nil 2))) + (if b + (- a))))) + (should (equal + (macroexpand + '(when-let ((a 1) nil (b 2)) + (- a))) + '(let* ((a (and t 1)) + (nil (and a nil)) + (b (and nil 2))) + (if b + (- a)))))) + +(ert-deftest subr-x-test-when-let-malformed-binding () + "Test malformed bindings trigger errors." + (should-error (macroexpand + '(when-let (_ (a 1 1) (b 2) (c 3) d) + (- a))) + :type 'error) + (should-error (macroexpand + '(when-let (_ (a 1) (b 2 2) (c 3) d) + (- a))) + :type 'error) + (should-error (macroexpand + '(when-let (_ (a 1) (b 2) (c 3 3) d) + (- a))) + :type 'error) + (should-error (macroexpand + '(when-let ((a 1 1)) + (- a))) + :type 'error)) + +(ert-deftest subr-x-test-when-let-true () + "Test `when-let' with truthy bindings." + (should (equal + (when-let (a 1) + a) + 1)) + (should (equal + (when-let ((a 1) (b 2) (c 3)) + (list a b c)) + (list 1 2 3)))) + +(ert-deftest subr-x-test-when-let-false () + "Test `when-let' with falsie bindings." + (should (equal + (when-let (a nil) + (list a b c) + "no") + nil)) + (should (equal + (when-let ((a nil) (b 2) (c 3)) + (list a b c) + "no") + nil)) + (should (equal + (when-let ((a 1) (b nil) (c 3)) + (list a b c) + "no") + nil)) + (should (equal + (when-let ((a 1) (b 2) (c nil)) + (list a b c) + "no") + nil)) + (should (equal + (when-let (z (a 1) (b 2) (c 3)) + (list a b c) + "no") + nil)) + (should (equal + (when-let ((a 1) (b 2) (c 3) d) + (list a b c) + "no") + nil))) + +(ert-deftest subr-x-test-when-let-bound-references () + "Test `when-let' bindings can refer to already bound symbols." + (should (equal + (when-let ((a (1+ 0)) (b (1+ a)) (c (1+ b))) + (list a b c)) + (list 1 2 3)))) + +(ert-deftest subr-x-test-when-let-and-laziness-is-preserved () + "Test `when-let' respects `and' laziness." + (let (a-called b-called c-called) + (should (equal + (progn + (when-let ((a nil) + (b (setq b-called t)) + (c (setq c-called t))) + "yes") + (list a-called b-called c-called)) + (list nil nil nil)))) + (let (a-called b-called c-called) + (should (equal + (progn + (when-let ((a (setq a-called t)) + (b nil) + (c (setq c-called t))) + "yes") + (list a-called b-called c-called)) + (list t nil nil)))) + (let (a-called b-called c-called) + (should (equal + (progn + (when-let ((a (setq a-called t)) + (b (setq b-called t)) + (c nil) + (d (setq c-called t))) + "yes") + (list a-called b-called c-called)) + (list t t nil))))) + + +;; Thread first tests + +(ert-deftest subr-x-test-thread-first-no-forms () + "Test `thread-first' with no forms expands to the first form." + (should (equal (macroexpand '(thread-first 5)) 5)) + (should (equal (macroexpand '(thread-first (+ 1 2))) '(+ 1 2)))) + +(ert-deftest subr-x-test-thread-first-function-names-are-threaded () + "Test `thread-first' wraps single function names." + (should (equal (macroexpand + '(thread-first 5 + -)) + '(- 5))) + (should (equal (macroexpand + '(thread-first (+ 1 2) + -)) + '(- (+ 1 2))))) + +(ert-deftest subr-x-test-thread-first-expansion () + "Test `thread-first' expands correctly." + (should (equal + (macroexpand '(thread-first + 5 + (+ 20) + (/ 25) + - + (+ 40))) + '(+ (- (/ (+ 5 20) 25)) 40)))) + +(ert-deftest subr-x-test-thread-first-examples () + "Test several `thread-first' examples." + (should (equal (thread-first (+ 40 2)) 42)) + (should (equal (thread-first + 5 + (+ 20) + (/ 25) + - + (+ 40)) 39)) + (should (equal (thread-first + "this-is-a-string" + (split-string "-") + (nbutlast 2) + (append (list "good"))) + (list "this" "is" "good")))) + +;; Thread last tests + +(ert-deftest subr-x-test-thread-last-no-forms () + "Test `thread-last' with no forms expands to the first form." + (should (equal (macroexpand '(thread-last 5)) 5)) + (should (equal (macroexpand '(thread-last (+ 1 2))) '(+ 1 2)))) + +(ert-deftest subr-x-test-thread-last-function-names-are-threaded () + "Test `thread-last' wraps single function names." + (should (equal (macroexpand + '(thread-last 5 + -)) + '(- 5))) + (should (equal (macroexpand + '(thread-last (+ 1 2) + -)) + '(- (+ 1 2))))) + +(ert-deftest subr-x-test-thread-last-expansion () + "Test `thread-last' expands correctly." + (should (equal + (macroexpand '(thread-last + 5 + (+ 20) + (/ 25) + - + (+ 40))) + '(+ 40 (- (/ 25 (+ 20 5))))))) + +(ert-deftest subr-x-test-thread-last-examples () + "Test several `thread-last' examples." + (should (equal (thread-last (+ 40 2)) 42)) + (should (equal (thread-last + 5 + (+ 20) + (/ 25) + - + (+ 40)) 39)) + (should (equal (thread-last + (list 1 -2 3 -4 5) + (mapcar #'abs) + (cl-reduce #'+) + (format "abs sum is: %s")) + "abs sum is: 15"))) + + +(provide 'subr-x-tests) +;;; subr-x-tests.el ends here diff --cc test/lisp/emacs-lisp/tabulated-list-test.el index 0fb8dee7fd1,00000000000..b3a09ee375c mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/tabulated-list-test.el +++ b/test/lisp/emacs-lisp/tabulated-list-test.el @@@ -1,118 -1,0 +1,118 @@@ +;;; tabulated-list-test.el --- Tests for emacs-lisp/tabulated-list.el -*- lexical-binding: t; -*- + - ;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2017 Free Software Foundation, Inc. + +;; Author: Artur Malabarba + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'tabulated-list) +(require 'ert) + +(defconst tabulated-list--test-entries + '(("zzzz-game" ["zzzz-game" "zzzz-game" "2113" "installed" " play zzzz in Emacs"]) + ("4clojure" ["4clojure" "4clojure" "1507" "obsolete" " Open and evaluate 4clojure.com questions"]) + ("abc-mode" ["abc-mode" "abc-mode" "944" "available" " Major mode for editing abc music files"]) + ("mode" ["mode" "mode" "1128" "installed" " A simple mode for editing Actionscript 3 files"]))) + +(defun tabulated-list--test-sort-car (a b) + (string< (car a) (car b))) + +(defconst tabulated-list--test-format + [("name" 10 tabulated-list--test-sort-car) + ("name-2" 10 t) + ("Version" 9 nil) + ("Status" 10 ) + ("Description" 0 nil)]) + +(defmacro tabulated-list--test-with-buffer (&rest body) + `(with-temp-buffer + (tabulated-list-mode) + (setq tabulated-list-entries (copy-alist tabulated-list--test-entries)) + (setq tabulated-list-format tabulated-list--test-format) + (setq tabulated-list-padding 7) + (tabulated-list-init-header) + (tabulated-list-print) + ,@body)) + + +;;; Tests +(ert-deftest tabulated-list-print () + (tabulated-list--test-with-buffer + ;; Basic printing. + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + " zzzz-game zzzz-game 2113 installed play zzzz in Emacs + 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions + abc-mode abc-mode 944 available Major mode for editing abc music files + mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) + ;; Preserve position. + (forward-line 3) + (let ((pos (thing-at-point 'line))) + (pop tabulated-list-entries) + (tabulated-list-print t) + (should (equal (thing-at-point 'line) pos)) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + " 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions + abc-mode abc-mode 944 available Major mode for editing abc music files + mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) + ;; Check the UPDATE argument + (pop tabulated-list-entries) + (setf (cdr (car tabulated-list-entries)) (list ["x" "x" "944" "available" " XX"])) + (tabulated-list-print t t) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + " x x 944 available XX + mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) + (should (equal (thing-at-point 'line) pos))))) + +(ert-deftest tabulated-list-sort () + (tabulated-list--test-with-buffer + ;; Basic sorting + (goto-char (point-min)) + (skip-chars-forward "[:blank:]") + (tabulated-list-sort) + (let ((text (buffer-substring-no-properties (point-min) (point-max)))) + (should (string= text " 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions + abc-mode abc-mode 944 available Major mode for editing abc music files + mode mode 1128 installed A simple mode for editing Actionscript 3 files + zzzz-game zzzz-game 2113 installed play zzzz in Emacs\n")) + + (skip-chars-forward "^[:blank:]") + (skip-chars-forward "[:blank:]") + (should (equal (get-text-property (point) 'tabulated-list-column-name) + "name-2")) + (tabulated-list-sort) + ;; Check a `t' as the sorting predicate. + (should (string= text (buffer-substring-no-properties (point-min) (point-max)))) + ;; Invert. + (tabulated-list-sort 1) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + " zzzz-game zzzz-game 2113 installed play zzzz in Emacs + mode mode 1128 installed A simple mode for editing Actionscript 3 files + abc-mode abc-mode 944 available Major mode for editing abc music files + 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions\n")) + ;; Again + (tabulated-list-sort 1) + (should (string= text (buffer-substring-no-properties (point-min) (point-max))))) + ;; Check that you can't sort some cols. + (skip-chars-forward "^[:blank:]") + (skip-chars-forward "[:blank:]") + (should-error (tabulated-list-sort) :type 'user-error) + (should-error (tabulated-list-sort 4) :type 'user-error))) + +(provide 'tabulated-list-test) +;;; tabulated-list-test.el ends here diff --cc test/lisp/emacs-lisp/thunk-tests.el index f995d362c7d,00000000000..89bf1f50113 mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/thunk-tests.el +++ b/test/lisp/emacs-lisp/thunk-tests.el @@@ -1,55 -1,0 +1,55 @@@ +;;; thunk-tests.el --- Tests for thunk.el -*- lexical-binding: t -*- + - ;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2017 Free Software Foundation, Inc. + +;; Author: Nicolas Petton +;; Maintainer: emacs-devel@gnu.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Tests for thunk.el + +;;; Code: + +(require 'ert) +(require 'thunk) + +(ert-deftest thunk-should-be-lazy () + (let (x) + (thunk-delay (setq x t)) + (should (null x)))) + +(ert-deftest thunk-can-be-evaluated () + (let* (x + (thunk (thunk-delay (setq x t)))) + (should-not (thunk-evaluated-p thunk)) + (should (null x)) + (thunk-force thunk) + (should (thunk-evaluated-p thunk)) + (should x))) + +(ert-deftest thunk-evaluation-is-cached () + (let* ((x 0) + (thunk (thunk-delay (setq x (1+ x))))) + (thunk-force thunk) + (should (= x 1)) + (thunk-force thunk) + (should (= x 1)))) + +(provide 'thunk-tests) +;;; thunk-tests.el ends here diff --cc test/lisp/emacs-lisp/timer-tests.el index e3cdec73232,00000000000..b12a365ff3b mode 100644,000000..100644 --- a/test/lisp/emacs-lisp/timer-tests.el +++ b/test/lisp/emacs-lisp/timer-tests.el @@@ -1,42 -1,0 +1,42 @@@ +;;; timer-tests.el --- tests for timers -*- lexical-binding:t -*- + - ;; Copyright (C) 2013-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(ert-deftest timer-tests-sit-for () + (let ((timer-ran nil) + ;; Want sit-for behavior when interactive + (noninteractive nil)) + (run-at-time '(0 0 0 0) + nil + (lambda () (setq timer-ran t))) + ;; The test assumes run-at-time didn't take the liberty of firing + ;; the timer, so assert the test's assumption + (should (not timer-ran)) + (sit-for 0 t) + (should timer-ran))) + +(ert-deftest timer-tests-debug-timer-check () + ;; This function exists only if --enable-checking. + (if (fboundp 'debug-timer-check) + (should (debug-timer-check)) t)) + +;;; timer-tests.el ends here diff --cc test/lisp/emulation/viper-tests.el index 2c63b24fae0,00000000000..67ce5b6fbb0 mode 100644,000000..100644 --- a/test/lisp/emulation/viper-tests.el +++ b/test/lisp/emulation/viper-tests.el @@@ -1,161 -1,0 +1,161 @@@ +;;; viper-tests.el --- tests for viper. + - ;; Copyright (C) 2016 Free Software Foundation, Inc. ++;; Copyright (C) 2016-2017 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + + +(require 'viper) + +(defun viper-test-undo-kmacro (kmacro) + "In a clean viper buffer, run KMACRO and return `buffer-string'. + +This function makes as many attempts as possible to clean up +after itself, although it will leave a buffer called +*viper-test-buffer* if it fails (this is deliberate!)." + (let ( + ;; Viper just turns itself off during batch use. + (noninteractive nil) + ;; Switch off start up message or it will chew the key presses. + (viper-inhibit-startup-message 't) + ;; Select an expert-level for the same reason. + (viper-expert-level 5) + ;; viper loads this even with -q so make sure it's empty! + (viper-custom-file-name (make-temp-file "viper-tests" nil ".elc")) + (before-buffer (current-buffer))) + (unwind-protect + (progn + ;; viper-mode is essentially global, so set it here. + (viper-mode) + ;; We must switch to buffer because we are using a keyboard macro + ;; which appears to not go to the current-buffer but what ever is + ;; currently taking keyboard events. We use a named buffer because + ;; then we can see what it in it if it all goes wrong. + (switch-to-buffer + (get-buffer-create + "*viper-test-buffer*")) + (erase-buffer) + ;; The new buffer fails to enter vi state so set it. + (viper-change-state-to-vi) + ;; Run the macro. + (execute-kbd-macro kmacro) + (let ((rtn + (buffer-substring-no-properties + (point-min) + (point-max)))) + ;; Kill the buffer iff the macro succeeds. + (kill-buffer) + rtn)) + ;; Switch everything off and restore the buffer. + (toggle-viper-mode) + (delete-file viper-custom-file-name) + (switch-to-buffer before-buffer)))) + +(ert-deftest viper-test-go () + "Test that this file is running." + (should t)) + +(ert-deftest viper-test-fix () + "Test that the viper kmacro fixture is working." + (should + (viper-test-undo-kmacro []))) + +(ert-deftest viper-test-undo-1 () + "Test for VI like undo behavior. + +Insert 1, then 2 on consecutive lines, followed by undo. This +should leave just 1 in the buffer. + +Test for Bug #22295" + (should + (equal + "1\n" + (viper-test-undo-kmacro + [ + ?a + ?1 + escape + ?o + ?2 + escape + ?u + ] + )))) + +(ert-deftest viper-test-undo-2 () + "Test for VI like undo behavior. + +Insert \"1 2 3 4 5\" then delete the 2, then the 4, and undo. +Should restore the 4, but leave the 2 deleted. + +Test for Bug #22295" + (should + (equal + "1 3 4 5\n" + (viper-test-undo-kmacro + [ + ?i + ?1 ? ?2 ? ?3 ? ?4 ? ?5 + escape + ?F ?2 ?d ?w + ?w ?d ?w + ?u + ])))) + +(ert-deftest viper-test-undo-3 () + "Test for VI like undo behavior. + +Insert \"1 2 3 4 5 6\", delete the 2, then the 3 4 and 5. +Should restore the 3 4 and 5 but not the 2. + +Test for Bug #22295" + (should + (equal + "1 3 4 5 6\n" + (viper-test-undo-kmacro + [ + ;; Insert this lot. + ?i ?1 ? ?2 ? ?3 ? ?4 ? ?5 ? ?6 + escape + ;; Start of line. + ?0 + ;; Move to 2, delete + ?w ?d ?w + ;; Delete 3 4 5 + ?. ?. ?. + ;; Undo del 5, then + ?u ?. ?. + ])))) + + +(ert-deftest viper-test-undo-4() + (should + (equal + "" + (viper-test-undo-kmacro + [ + ?i ?1 escape + ?o ?2 escape + ?o ?3 escape + ?u ?. ?. + ]) + ))) + +;;; viper-tests.el ends here diff --cc test/lisp/epg-tests.el index d51ab23f71e,00000000000..ea2b62c3584 mode 100644,000000..100644 --- a/test/lisp/epg-tests.el +++ b/test/lisp/epg-tests.el @@@ -1,178 -1,0 +1,178 @@@ +;;; epg-tests.el --- Test suite for epg.el -*- lexical-binding: t -*- + - ;; Copyright (C) 2013-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'epg) + +(defvar epg-tests-context nil) + +(defvar epg-tests-data-directory + (expand-file-name "data/epg" (getenv "EMACS_TEST_DIRECTORY")) + "Directory containing epg test data.") + +(defconst epg-tests-program-alist-for-passphrase-callback + '((OpenPGP + nil + ("gpg" . "1.4.3")))) + +(defun epg-tests-find-usable-gpg-configuration (&optional require-passphrase) + (epg-find-configuration + 'OpenPGP + 'no-cache + (if require-passphrase + epg-tests-program-alist-for-passphrase-callback))) + +(defun epg-tests-passphrase-callback (_c _k _d) + ;; Need to create a copy here, since the string will be wiped out + ;; after the use. + (copy-sequence "test0123456789")) + +(cl-defmacro with-epg-tests ((&optional &key require-passphrase + require-public-key + require-secret-key) + &rest body) + "Set up temporary locations and variables for testing." + (declare (indent 1)) + `(let ((epg-tests-home-directory (make-temp-file "epg-tests-homedir" t))) + (unwind-protect + (let ((context (epg-make-context 'OpenPGP))) + (setf (epg-context-program context) + (alist-get 'program + (epg-tests-find-usable-gpg-configuration + ,(if require-passphrase + `'require-passphrase)))) + (setf (epg-context-home-directory context) + epg-tests-home-directory) + (setenv "GPG_AGENT_INFO") + ,(if require-passphrase + `(epg-context-set-passphrase-callback + context + #'epg-tests-passphrase-callback)) + ,(if require-public-key + `(epg-import-keys-from-file + context + (expand-file-name "pubkey.asc" epg-tests-data-directory))) + ,(if require-secret-key + `(epg-import-keys-from-file + context + (expand-file-name "seckey.asc" epg-tests-data-directory))) + (with-temp-buffer + (make-local-variable 'epg-tests-context) + (setq epg-tests-context context) + ,@body)) + (when (file-directory-p epg-tests-home-directory) + (delete-directory epg-tests-home-directory t))))) + +(ert-deftest epg-decrypt-1 () + (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) + (with-epg-tests (:require-passphrase t) + (should (equal "test" + (epg-decrypt-string epg-tests-context "\ +-----BEGIN PGP MESSAGE----- +Version: GnuPG v2 + +jA0EAwMCE19JBLTvvmhgyRrGGglRbnKkK9PJG8fDwO5ccjysrR7IcdNcnA== +=U8z7 +-----END PGP MESSAGE-----"))))) + +(ert-deftest epg-roundtrip-1 () + (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) + (with-epg-tests (:require-passphrase t) + (let ((cipher (epg-encrypt-string epg-tests-context "symmetric" nil))) + (should (equal "symmetric" + (epg-decrypt-string epg-tests-context cipher)))))) + +(ert-deftest epg-roundtrip-2 () + (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) + (with-epg-tests (:require-passphrase t + :require-public-key t + :require-secret-key t) + (let* ((recipients (epg-list-keys epg-tests-context "joe@example.com")) + (cipher (epg-encrypt-string epg-tests-context "public key" + recipients nil t))) + (should (equal "public key" + (epg-decrypt-string epg-tests-context cipher)))))) + +(ert-deftest epg-sign-verify-1 () + (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) + (with-epg-tests (:require-passphrase t + :require-public-key t + :require-secret-key t) + (let (signature verify-result) + (setf (epg-context-signers epg-tests-context) + (epg-list-keys epg-tests-context "joe@example.com")) + (setq signature (epg-sign-string epg-tests-context "signed" t)) + (epg-verify-string epg-tests-context signature "signed") + (setq verify-result (epg-context-result-for context 'verify)) + (should (= 1 (length verify-result))) + (should (eq 'good (epg-signature-status (car verify-result))))))) + +(ert-deftest epg-sign-verify-2 () + (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) + (with-epg-tests (:require-passphrase t + :require-public-key t + :require-secret-key t) + (let (signature verify-result) + (setf (epg-context-signers epg-tests-context) + (epg-list-keys epg-tests-context "joe@example.com")) + (setq signature (epg-sign-string epg-tests-context "clearsigned" 'clear)) + ;; Clearsign signature always ends with a new line. + (should (equal "clearsigned\n" + (epg-verify-string epg-tests-context signature))) + (setq verify-result (epg-context-result-for context 'verify)) + (should (= 1 (length verify-result))) + (should (eq 'good (epg-signature-status (car verify-result))))))) + +(ert-deftest epg-sign-verify-3 () + (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) + (with-epg-tests (:require-passphrase t + :require-public-key t + :require-secret-key t) + (let (signature verify-result) + (setf (epg-context-signers epg-tests-context) + (epg-list-keys epg-tests-context "joe@example.com")) + (setq signature (epg-sign-string epg-tests-context "normal signed")) + (should (equal "normal signed" + (epg-verify-string epg-tests-context signature))) + (setq verify-result (epg-context-result-for context 'verify)) + (should (= 1 (length verify-result))) + (should (eq 'good (epg-signature-status (car verify-result))))))) + +(ert-deftest epg-import-1 () + (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) + (with-epg-tests (:require-passphrase nil) + (should (= 0 (length (epg-list-keys epg-tests-context)))) + (should (= 0 (length (epg-list-keys epg-tests-context nil t))))) + (with-epg-tests (:require-passphrase nil + :require-public-key t) + (should (= 1 (length (epg-list-keys epg-tests-context)))) + (should (= 0 (length (epg-list-keys epg-tests-context nil t))))) + (with-epg-tests (:require-public-key nil + :require-public-key t + :require-secret-key t) + (should (= 1 (length (epg-list-keys epg-tests-context)))) + (should (= 1 (length (epg-list-keys epg-tests-context nil t)))))) + +(provide 'epg-tests) + +;;; epg-tests.el ends here diff --cc test/lisp/eshell/eshell.el index d5676dd1daf,00000000000..dee6c17e025 mode 100644,000000..100644 --- a/test/lisp/eshell/eshell.el +++ b/test/lisp/eshell/eshell.el @@@ -1,252 -1,0 +1,252 @@@ +;;; tests/eshell.el --- Eshell test suite + - ;; Copyright (C) 1999-2016 Free Software Foundation, Inc. ++;; Copyright (C) 1999-2017 Free Software Foundation, Inc. + +;; Author: John Wiegley + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Eshell test suite. + +;;; Code: + +(require 'ert) +(require 'eshell) + +(defmacro with-temp-eshell (&rest body) + "Evaluate BODY in a temporary Eshell buffer." + `(let* ((eshell-directory-name (make-temp-file "eshell" t)) + (eshell-history-file-name nil) + (eshell-buffer (eshell t))) + (unwind-protect + (with-current-buffer eshell-buffer + ,@body) + (let (kill-buffer-query-functions) + (kill-buffer eshell-buffer) + (delete-directory eshell-directory-name t))))) + +(defun eshell-insert-command (text &optional func) + "Insert a command at the end of the buffer." + (goto-char eshell-last-output-end) + (insert-and-inherit text) + (funcall (or func 'eshell-send-input))) + +(defun eshell-match-result (regexp) + "Check that text after `eshell-last-input-end' matches REGEXP." + (goto-char eshell-last-input-end) + (should (string-match-p regexp (buffer-substring-no-properties + (point) (point-max))))) + +(defun eshell-command-result-p (text regexp &optional func) + "Insert a command at the end of the buffer." + (eshell-insert-command text func) + (eshell-match-result regexp)) + +(defun eshell-test-command-result (command) + "Like `eshell-command-result', but not using HOME." + (let ((eshell-directory-name (make-temp-file "eshell" t)) + (eshell-history-file-name nil)) + (unwind-protect + (eshell-command-result command) + (delete-directory eshell-directory-name t)))) + +;;; Tests: + +(ert-deftest eshell-test/simple-command-result () + "Test `eshell-command-result' with a simple command." + (should (equal (eshell-test-command-result "+ 1 2") 3))) + +(ert-deftest eshell-test/lisp-command () + "Test `eshell-command-result' with an elisp command." + (should (equal (eshell-test-command-result "(+ 1 2)") 3))) + +(ert-deftest eshell-test/for-loop () + "Test `eshell-command-result' with a for loop.." + (let ((process-environment (cons "foo" process-environment))) + (should (equal (eshell-test-command-result + "for foo in 5 { echo $foo }") 5)))) + +(ert-deftest eshell-test/for-name-loop () ;Bug#15231 + "Test `eshell-command-result' with a for loop using `name'." + (let ((process-environment (cons "name" process-environment))) + (should (equal (eshell-test-command-result + "for name in 3 { echo $name }") 3)))) + +(ert-deftest eshell-test/for-name-shadow-loop () ; bug#15372 + "Test `eshell-command-result' with a for loop using an env-var." + (let ((process-environment (cons "name=env-value" process-environment))) + (with-temp-eshell + (eshell-command-result-p "echo $name; for name in 3 { echo $name }; echo $name" + "env-value\n3\nenv-value\n")))) + +(ert-deftest eshell-test/lisp-command-args () + "Test `eshell-command-result' with elisp and trailing args. +Test that trailing arguments outside the S-expression are +ignored. e.g. \"(+ 1 2) 3\" => 3" + (should (equal (eshell-test-command-result "(+ 1 2) 3") 3))) + +(ert-deftest eshell-test/subcommand () + "Test `eshell-command-result' with a simple subcommand." + (should (equal (eshell-test-command-result "{+ 1 2}") 3))) + +(ert-deftest eshell-test/subcommand-args () + "Test `eshell-command-result' with a subcommand and trailing args. +Test that trailing arguments outside the subcommand are ignored. +e.g. \"{+ 1 2} 3\" => 3" + (should (equal (eshell-test-command-result "{+ 1 2} 3") 3))) + +(ert-deftest eshell-test/subcommand-lisp () + "Test `eshell-command-result' with an elisp subcommand and trailing args. +Test that trailing arguments outside the subcommand are ignored. +e.g. \"{(+ 1 2)} 3\" => 3" + (should (equal (eshell-test-command-result "{(+ 1 2)} 3") 3))) + +(ert-deftest eshell-test/interp-cmd () + "Interpolate command result" + (should (equal (eshell-test-command-result "+ ${+ 1 2} 3") 6))) + +(ert-deftest eshell-test/interp-lisp () + "Interpolate Lisp form evaluation" + (should (equal (eshell-test-command-result "+ $(+ 1 2) 3") 6))) + +(ert-deftest eshell-test/interp-concat () + "Interpolate and concat command" + (should (equal (eshell-test-command-result "+ ${+ 1 2}3 3") 36))) + +(ert-deftest eshell-test/interp-concat-lisp () + "Interpolate and concat Lisp form" + (should (equal (eshell-test-command-result "+ $(+ 1 2)3 3") 36))) + +(ert-deftest eshell-test/interp-concat2 () + "Interpolate and concat two commands" + (should (equal (eshell-test-command-result "+ ${+ 1 2}${+ 1 2} 3") 36))) + +(ert-deftest eshell-test/interp-concat-lisp2 () + "Interpolate and concat two Lisp forms" + (should (equal (eshell-test-command-result "+ $(+ 1 2)$(+ 1 2) 3") 36))) + +(ert-deftest eshell-test/window-height () + "$LINES should equal (window-height)" + (should (eshell-test-command-result "= $LINES (window-height)"))) + +(ert-deftest eshell-test/window-width () + "$COLUMNS should equal (window-width)" + (should (eshell-test-command-result "= $COLUMNS (window-width)"))) + +(ert-deftest eshell-test/last-result-var () + "Test using the \"last result\" ($$) variable" + (with-temp-eshell + (eshell-command-result-p "+ 1 2; + $$ 2" + "3\n5\n"))) + +(ert-deftest eshell-test/last-result-var2 () + "Test using the \"last result\" ($$) variable twice" + (with-temp-eshell + (eshell-command-result-p "+ 1 2; + $$ $$" + "3\n6\n"))) + +(ert-deftest eshell-test/last-arg-var () + "Test using the \"last arg\" ($_) variable" + (with-temp-eshell + (eshell-command-result-p "+ 1 2; + $_ 4" + "3\n6\n"))) + +(ert-deftest eshell-test/escape-nonspecial () + "Test that \"\\c\" and \"c\" are equivalent when \"c\" is not a +special character." + (with-temp-eshell + (eshell-command-result-p "echo he\\llo" + "hello\n"))) + +(ert-deftest eshell-test/escape-nonspecial-unicode () + "Test that \"\\c\" and \"c\" are equivalent when \"c\" is a +unicode character (unicode characters are nonspecial by +definition)." + (with-temp-eshell + (eshell-command-result-p "echo Vid\\éos" + "Vidéos\n"))) + +(ert-deftest eshell-test/escape-nonspecial-quoted () + "Test that the backslash is preserved for escaped nonspecial +chars" + (with-temp-eshell + (eshell-command-result-p "echo \"h\\i\"" + ;; Backslashes are doubled for regexp. + "h\\\\i\n"))) + +(ert-deftest eshell-test/escape-special-quoted () + "Test that the backslash is not preserved for escaped special +chars" + (with-temp-eshell + (eshell-command-result-p "echo \"h\\\\i\"" + ;; Backslashes are doubled for regexp. + "h\\\\i\n"))) + +(ert-deftest eshell-test/command-running-p () + "Modeline should show no command running" + (with-temp-eshell + (let ((eshell-status-in-mode-line t)) + (should (memq 'eshell-command-running-string mode-line-format)) + (should (equal eshell-command-running-string "--"))))) + +(ert-deftest eshell-test/forward-arg () + "Test moving across command arguments" + (with-temp-eshell + (eshell-insert-command "echo $(+ 1 (- 4 3)) \"alpha beta\" file" 'ignore) + (let ((here (point)) begin valid) + (eshell-bol) + (setq begin (point)) + (eshell-forward-argument 4) + (setq valid (= here (point))) + (eshell-backward-argument 4) + (prog1 + (and valid (= begin (point))) + (eshell-bol) + (delete-region (point) (point-max)))))) + +(ert-deftest eshell-test/queue-input () + "Test queuing command input" + (with-temp-eshell + (eshell-insert-command "sleep 2") + (eshell-insert-command "echo alpha" 'eshell-queue-input) + (let ((count 10)) + (while (and eshell-current-command + (> count 0)) + (sit-for 1) + (setq count (1- count)))) + (eshell-match-result "alpha\n"))) + +(ert-deftest eshell-test/flush-output () + "Test flushing of previous output" + (with-temp-eshell + (eshell-insert-command "echo alpha") + (eshell-kill-output) + (eshell-match-result (regexp-quote "*** output flushed ***\n")) + (should (forward-line)) + (should (= (point) eshell-last-output-start)))) + +(ert-deftest eshell-test/run-old-command () + "Re-run an old command" + (with-temp-eshell + (eshell-insert-command "echo alpha") + (goto-char eshell-last-input-start) + (string= (eshell-get-old-input) "echo alpha"))) + +(provide 'esh-test) + +;;; tests/eshell.el ends here diff --cc test/lisp/faces-tests.el index 809ba24d210,00000000000..a30ba25f8f0 mode 100644,000000..100644 --- a/test/lisp/faces-tests.el +++ b/test/lisp/faces-tests.el @@@ -1,59 -1,0 +1,59 @@@ +;;; faces-tests.el --- Tests for faces.el -*- lexical-binding: t; -*- + - ;; Copyright (C) 2013-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + +;; Author: Artur Malabarba +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'ert) +(require 'faces) + +(defface faces--test1 + '((t :background "black" :foreground "black")) + "") + +(defface faces--test2 + '((t :box 1)) + "") + +(ert-deftest faces--test-color-at-point () + (with-temp-buffer + (insert (propertize "STRING" 'face '(faces--test2 faces--test1))) + (goto-char (point-min)) + (should (equal (background-color-at-point) "black")) + (should (equal (foreground-color-at-point) "black"))) + (with-temp-buffer + (insert (propertize "STRING" 'face '(:foreground "black" :background "black"))) + (goto-char (point-min)) + (should (equal (background-color-at-point) "black")) + (should (equal (foreground-color-at-point) "black"))) + (with-temp-buffer + (emacs-lisp-mode) + (setq-local font-lock-comment-face 'faces--test1) + (setq-local font-lock-constant-face 'faces--test2) + (insert ";; `symbol'") + (font-lock-fontify-region (point-min) (point-max)) + (goto-char (point-min)) + (should (equal (background-color-at-point) "black")) + (should (equal (foreground-color-at-point) "black")) + (goto-char 6) + (should (equal (background-color-at-point) "black")) + (should (equal (foreground-color-at-point) "black")))) + +(provide 'faces-tests) +;;; faces-tests.el ends here diff --cc test/lisp/filenotify-tests.el index bd7f191dac6,00000000000..2c085b34de9 mode 100644,000000..100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@@ -1,1204 -1,0 +1,1204 @@@ +;;; filenotify-tests.el --- Tests of file notifications -*- lexical-binding: t; -*- + - ;; Copyright (C) 2013-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + +;; Author: Michael Albinus + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; Some of the tests require access to a remote host files. Since +;; this could be problematic, a mock-up connection method "mock" is +;; used. Emulating a remote connection, it simply calls "sh -i". +;; Tramp's file name handlers still run, so this test is sufficient +;; except for connection establishing. + +;; If you want to test a real Tramp connection, set +;; $REMOTE_TEMPORARY_FILE_DIRECTORY to a suitable value in order to +;; overwrite the default value. If you want to skip tests accessing a +;; remote host, set this environment variable to "/dev/null" or +;; whatever is appropriate on your system. + +;; A whole test run can be performed calling the command `file-notify-test-all'. + +;;; Code: + +(require 'ert) +(require 'filenotify) +(require 'tramp) + +;; There is no default value on w32 systems, which could work out of the box. +(defconst file-notify-test-remote-temporary-file-directory + (cond + ((getenv "REMOTE_TEMPORARY_FILE_DIRECTORY")) + ((eq system-type 'windows-nt) null-device) + (t (add-to-list + 'tramp-methods + '("mock" + (tramp-login-program "sh") + (tramp-login-args (("-i"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10))) + (format "/mock::%s" temporary-file-directory))) + "Temporary directory for Tramp tests.") + +(defvar file-notify--test-tmpfile nil) +(defvar file-notify--test-tmpfile1 nil) +(defvar file-notify--test-desc nil) +(defvar file-notify--test-desc1 nil) +(defvar file-notify--test-desc2 nil) +(defvar file-notify--test-results nil) +(defvar file-notify--test-event nil) +(defvar file-notify--test-events nil) + +(defun file-notify--test-read-event () + "Read one event. +There are different timeouts for local and remote file notification libraries." + (read-event + nil nil + (cond + ;; gio/gpollfilemonitor.c declares POLL_TIME_SECS 5. So we must + ;; wait at least this time in the GPollFileMonitor case. A + ;; similar timeout seems to be needed in the GFamFileMonitor case, + ;; at least on Cygwin. + ((and (string-equal (file-notify--test-library) "gfilenotify") + (memq (file-notify--test-monitor) + '(GFamFileMonitor GPollFileMonitor))) + 7) + ((file-remote-p temporary-file-directory) 0.1) + (t 0.01)))) + +(defun file-notify--test-timeout () + "Timeout to wait for arriving a bunch of events, in seconds." + (cond + ((file-remote-p temporary-file-directory) 6) + ((string-equal (file-notify--test-library) "w32notify") 4) + ((eq system-type 'cygwin) 6) + (t 3))) + +(defmacro file-notify--wait-for-events (timeout until) + "Wait for and return file notification events until form UNTIL is true. +TIMEOUT is the maximum time to wait for, in seconds." + `(with-timeout (,timeout (ignore)) + (while (null ,until) + (file-notify--test-read-event)))) + +(defun file-notify--test-no-descriptors () + "Check that `file-notify-descriptors' is an empty hash table. +Return nil when any other file notification watch is still active." + ;; Give read events a last chance. + (file-notify--wait-for-events + (file-notify--test-timeout) + (zerop (hash-table-count file-notify-descriptors))) + ;; Now check. + (zerop (hash-table-count file-notify-descriptors))) + +(defun file-notify--test-no-descriptors-explainer () + "Explain why `file-notify--test-no-descriptors' fails." + (let ((result (list "Watch descriptor(s) existent:"))) + (maphash + (lambda (key value) (push (cons key value) result)) + file-notify-descriptors) + (nreverse result))) + +(put 'file-notify--test-no-descriptors 'ert-explainer + 'file-notify--test-no-descriptors-explainer) + +(defun file-notify--test-cleanup-p () + "Check, that the test has cleaned up the environment as much as needed." + ;; `file-notify--test-event' should not be set but bound + ;; dynamically. + (should-not file-notify--test-event) + ;; The test should have cleaned up this already. Let's check + ;; nevertheless. + (should (file-notify--test-no-descriptors))) + +(defun file-notify--test-cleanup () + "Cleanup after a test." + (file-notify-rm-watch file-notify--test-desc) + (file-notify-rm-watch file-notify--test-desc1) + (file-notify-rm-watch file-notify--test-desc2) + + (ignore-errors + (delete-file (file-newest-backup file-notify--test-tmpfile))) + (ignore-errors + (if (file-directory-p file-notify--test-tmpfile) + (delete-directory file-notify--test-tmpfile 'recursive) + (delete-file file-notify--test-tmpfile))) + (ignore-errors + (if (file-directory-p file-notify--test-tmpfile1) + (delete-directory file-notify--test-tmpfile1 'recursive) + (delete-file file-notify--test-tmpfile1))) + (ignore-errors + (when (file-remote-p temporary-file-directory) + (tramp-cleanup-connection + (tramp-dissect-file-name temporary-file-directory) nil 'keep-password))) + + (setq file-notify--test-tmpfile nil + file-notify--test-tmpfile1 nil + file-notify--test-desc nil + file-notify--test-desc1 nil + file-notify--test-desc2 nil + file-notify--test-results nil + file-notify--test-events nil)) + +(setq password-cache-expiry nil + tramp-verbose 0 + tramp-message-show-message nil) + +;; This shall happen on hydra only. +(when (getenv "NIX_STORE") + (add-to-list 'tramp-remote-path 'tramp-own-remote-path)) + +;; We do not want to try and fail `file-notify-add-watch'. +(defun file-notify--test-local-enabled () + "Whether local file notification is enabled. +This is needed for local `temporary-file-directory' only, in the +remote case we return always t." + (or file-notify--library + (file-remote-p temporary-file-directory))) + +(defvar file-notify--test-remote-enabled-checked nil + "Cached result of `file-notify--test-remote-enabled'. +If the function did run, the value is a cons cell, the `cdr' +being the result.") + +(defun file-notify--test-remote-enabled () + "Whether remote file notification is enabled." + (unless (consp file-notify--test-remote-enabled-checked) + (let (desc) + (ignore-errors + (and + (file-remote-p file-notify-test-remote-temporary-file-directory) + (file-directory-p file-notify-test-remote-temporary-file-directory) + (file-writable-p file-notify-test-remote-temporary-file-directory) + (setq desc + (file-notify-add-watch + file-notify-test-remote-temporary-file-directory + '(change) #'ignore)))) + (setq file-notify--test-remote-enabled-checked (cons t desc)) + (when desc (file-notify-rm-watch desc)))) + ;; Return result. + (cdr file-notify--test-remote-enabled-checked)) + +(defun file-notify--test-library () + "The used library for the test, as a string. +In the remote case, it is the process name which runs on the +remote host, or nil." + (if (null (file-remote-p temporary-file-directory)) + (symbol-name file-notify--library) + (and (consp file-notify--test-remote-enabled-checked) + (processp (cdr file-notify--test-remote-enabled-checked)) + (replace-regexp-in-string + "<[[:digit:]]+>\\'" "" + (process-name (cdr file-notify--test-remote-enabled-checked)))))) + +(defun file-notify--test-monitor () + "The used monitor for the test, as a symbol. +This returns only for the local case and gfilenotify; otherwise it is nil. +`file-notify--test-desc' must be a valid watch descriptor." + (and file-notify--test-desc + (null (file-remote-p temporary-file-directory)) + (functionp 'gfile-monitor-name) + (gfile-monitor-name file-notify--test-desc))) + +(defmacro file-notify--deftest-remote (test docstring) + "Define ert `TEST-remote' for remote files." + (declare (indent 1)) + `(ert-deftest ,(intern (concat (symbol-name test) "-remote")) () + ,docstring + :tags '(:expensive-test) + (let* ((temporary-file-directory + file-notify-test-remote-temporary-file-directory) + (ert-test (ert-get-test ',test))) + (skip-unless (file-notify--test-remote-enabled)) + (tramp-cleanup-connection + (tramp-dissect-file-name temporary-file-directory) nil 'keep-password) + (funcall (ert-test-body ert-test))))) + +(ert-deftest file-notify-test00-availability () + "Test availability of `file-notify'." + (skip-unless (file-notify--test-local-enabled)) + + (unwind-protect + (progn + ;; Report the native library which has been used. + (message "Library: `%s'" (file-notify--test-library)) + (should + (setq file-notify--test-desc + (file-notify-add-watch + temporary-file-directory '(change) #'ignore))) + (when (file-notify--test-monitor) + (message "Monitor: `%s'" (file-notify--test-monitor))) + (file-notify-rm-watch file-notify--test-desc) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup))) + +(file-notify--deftest-remote file-notify-test00-availability + "Test availability of `file-notify' for remote files.") + +(ert-deftest file-notify-test01-add-watch () + "Check `file-notify-add-watch'." + (skip-unless (file-notify--test-local-enabled)) + + (unwind-protect + (progn + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-tmpfile1 + (format + "%s/%s" file-notify--test-tmpfile (md5 (current-time-string)))) + + ;; Check, that different valid parameters are accepted. + (should + (setq file-notify--test-desc + (file-notify-add-watch + temporary-file-directory '(change) #'ignore))) + (file-notify-rm-watch file-notify--test-desc) + (should + (setq file-notify--test-desc + (file-notify-add-watch + temporary-file-directory '(attribute-change) #'ignore))) + (file-notify-rm-watch file-notify--test-desc) + (should + (setq file-notify--test-desc + (file-notify-add-watch + temporary-file-directory '(change attribute-change) #'ignore))) + (file-notify-rm-watch file-notify--test-desc) + (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile '(change attribute-change) #'ignore))) + (file-notify-rm-watch file-notify--test-desc) + (delete-file file-notify--test-tmpfile) + + ;; Check error handling. + (should-error (file-notify-add-watch 1 2 3 4) + :type 'wrong-number-of-arguments) + (should + (equal (should-error + (file-notify-add-watch 1 2 3)) + '(wrong-type-argument 1))) + (should + (equal (should-error + (file-notify-add-watch temporary-file-directory 2 3)) + '(wrong-type-argument 2))) + (should + (equal (should-error + (file-notify-add-watch temporary-file-directory '(change) 3)) + '(wrong-type-argument 3))) + ;; The upper directory of a file must exist. + (should + (equal (should-error + (file-notify-add-watch + file-notify--test-tmpfile1 + '(change attribute-change) #'ignore)) + `(file-notify-error + "Directory does not exist" ,file-notify--test-tmpfile))) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup))) + +(file-notify--deftest-remote file-notify-test01-add-watch + "Check `file-notify-add-watch' for remote files.") + +(defun file-notify--test-event-test () + "Ert test function to be called by `file-notify--test-event-handler'. +We cannot pass arguments, so we assume that `file-notify--test-event' +is bound somewhere." + ;; Check the descriptor. + (should (equal (car file-notify--test-event) file-notify--test-desc)) + ;; Check the file name. + (should + (string-prefix-p + (file-notify--event-watched-file file-notify--test-event) + (file-notify--event-file-name file-notify--test-event))) + ;; Check the second file name if exists. + (when (eq (nth 1 file-notify--test-event) 'renamed) + (should + (string-prefix-p + (file-notify--event-watched-file file-notify--test-event) + (file-notify--event-file1-name file-notify--test-event))))) + +(defun file-notify--test-event-handler (event) + "Run a test over FILE-NOTIFY--TEST-EVENT. +For later analysis, append the test result to `file-notify--test-results' +and the event to `file-notify--test-events'." + (let* ((file-notify--test-event event) + (result + (ert-run-test (make-ert-test :body 'file-notify--test-event-test)))) + ;; Do not add lock files, this would confuse the checks. + (unless (string-match + (regexp-quote ".#") + (file-notify--event-file-name file-notify--test-event)) + ;;(message "file-notify--test-event-handler result: %s event: %S" + ;;(null (ert-test-failed-p result)) file-notify--test-event) + (setq file-notify--test-events + (append file-notify--test-events `(,file-notify--test-event)) + file-notify--test-results + (append file-notify--test-results `(,result)))))) + +(defun file-notify--test-make-temp-name () + "Create a temporary file name for test." + (expand-file-name + (make-temp-name "file-notify-test") temporary-file-directory)) + +(defun file-notify--test-with-events-check (events) + "Check whether received events match one of the EVENTS alternatives." + (let (result) + (dolist (elt events result) + (setq result + (or result + (if (eq (car elt) :random) + (equal (sort (cdr elt) 'string-lessp) + (sort (mapcar #'cadr file-notify--test-events) + 'string-lessp)) + (equal elt (mapcar #'cadr file-notify--test-events)))))))) + +(defun file-notify--test-with-events-explainer (events) + "Explain why `file-notify--test-with-events-check' fails." + (if (null (cdr events)) + (format "Received events do not match expected events\n%s\n%s" + (mapcar #'cadr file-notify--test-events) (car events)) + (format + "Received events do not match any sequence of expected events\n%s\n%s" + (mapcar #'cadr file-notify--test-events) events))) + +(put 'file-notify--test-with-events-check 'ert-explainer + 'file-notify--test-with-events-explainer) + +(defmacro file-notify--test-with-events (events &rest body) + "Run BODY collecting events and then compare with EVENTS. +EVENTS is either a simple list of events, or a list of lists of +events, which represent different possible results. The first +event of a list could be the pseudo event `:random', which is +just an indicator for comparison. + +Don't wait longer than timeout seconds for the events to be +delivered." + (declare (indent 1)) + `(let* ((events (if (consp (car ,events)) ,events (list ,events))) + (max-length + (apply + 'max + (mapcar + (lambda (x) (length (if (eq (car x) :random) (cdr x) x))) + events))) + create-lockfiles) + ;; Flush pending events. + (file-notify--test-read-event) + (file-notify--wait-for-events + (file-notify--test-timeout) + (not (input-pending-p))) + (setq file-notify--test-events nil + file-notify--test-results nil) + ,@body + (file-notify--wait-for-events + ;; More events need more time. Use some fudge factor. + (* (ceiling max-length 100) (file-notify--test-timeout)) + (= max-length (length file-notify--test-events))) + ;; Check the result sequence just to make sure that all events + ;; are as expected. + (dolist (result file-notify--test-results) + (when (ert-test-failed-p result) + (ert-fail + (cadr (ert-test-result-with-condition-condition result))))) + ;; One of the possible event sequences shall match. + (should (file-notify--test-with-events-check events)))) + +(ert-deftest file-notify-test02-events () + "Check file creation/change/removal notifications." + (skip-unless (file-notify--test-local-enabled)) + + (unwind-protect + (progn + ;; Check file creation, change and deletion. It doesn't work + ;; for kqueue, because we don't use an implicit directory + ;; monitor. + (unless (string-equal (file-notify--test-library) "kqueue") + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) #'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; cygwin does not raise a `changed' event. + ((eq system-type 'cygwin) + '(created deleted stopped)) + (t '(created changed deleted stopped))) + (write-region + "another text" nil file-notify--test-tmpfile nil 'no-message) + (file-notify--test-read-event) + (delete-file file-notify--test-tmpfile)) + (file-notify-rm-watch file-notify--test-desc)) + + ;; Check file change and deletion. + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) #'file-notify--test-event-handler))) + (file-notify--test-with-events + ;; There could be one or two `changed' events. + '((changed deleted stopped) + (changed changed deleted stopped)) + (write-region + "another text" nil file-notify--test-tmpfile nil 'no-message) + (file-notify--test-read-event) + (delete-file file-notify--test-tmpfile)) + (file-notify-rm-watch file-notify--test-desc) + + ;; Check file creation, change and deletion when watching a + ;; directory. There must be a `stopped' event when deleting + ;; the directory. + (let ((temporary-file-directory + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-desc + (file-notify-add-watch + temporary-file-directory + '(change) #'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; w32notify does not raise `deleted' and `stopped' + ;; events for the watched directory. + ((string-equal (file-notify--test-library) "w32notify") + '(created changed deleted)) + ;; There are two `deleted' events, for the file and for + ;; the directory. Except for cygwin and kqueue. And + ;; cygwin does not raise a `changed' event. + ((eq system-type 'cygwin) + '(created deleted stopped)) + ((string-equal (file-notify--test-library) "kqueue") + '(created changed deleted stopped)) + (t '(created changed deleted deleted stopped))) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (file-notify--test-read-event) + (delete-directory temporary-file-directory 'recursive)) + (file-notify-rm-watch file-notify--test-desc)) + + ;; Check copy of files inside a directory. + (let ((temporary-file-directory + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-tmpfile1 (file-notify--test-make-temp-name) + file-notify--test-desc + (file-notify-add-watch + temporary-file-directory + '(change) #'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; w32notify does not distinguish between `changed' and + ;; `attribute-changed'. It does not raise `deleted' + ;; and `stopped' events for the watched directory. + ((string-equal (file-notify--test-library) "w32notify") + '(created changed created changed + changed changed changed + deleted deleted)) + ;; There are three `deleted' events, for two files and + ;; for the directory. Except for cygwin and kqueue. + ((eq system-type 'cygwin) + '(created created changed changed deleted stopped)) + ((string-equal (file-notify--test-library) "kqueue") + '(created changed created changed deleted stopped)) + (t '(created changed created changed + deleted deleted deleted stopped))) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (file-notify--test-read-event) + (copy-file file-notify--test-tmpfile file-notify--test-tmpfile1) + ;; The next two events shall not be visible. + (file-notify--test-read-event) + (set-file-modes file-notify--test-tmpfile 000) + (file-notify--test-read-event) + (set-file-times file-notify--test-tmpfile '(0 0)) + (file-notify--test-read-event) + (delete-directory temporary-file-directory 'recursive)) + (file-notify-rm-watch file-notify--test-desc)) + + ;; Check rename of files inside a directory. + (let ((temporary-file-directory + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-tmpfile1 (file-notify--test-make-temp-name) + file-notify--test-desc + (file-notify-add-watch + temporary-file-directory + '(change) #'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; w32notify does not raise `deleted' and `stopped' + ;; events for the watched directory. + ((string-equal (file-notify--test-library) "w32notify") + '(created changed renamed deleted)) + ;; There are two `deleted' events, for the file and for + ;; the directory. Except for cygwin and kqueue. And + ;; cygwin raises `created' and `deleted' events instead + ;; of a `renamed' event. + ((eq system-type 'cygwin) + '(created created deleted deleted stopped)) + ((string-equal (file-notify--test-library) "kqueue") + '(created changed renamed deleted stopped)) + (t '(created changed renamed deleted deleted stopped))) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (file-notify--test-read-event) + (rename-file file-notify--test-tmpfile file-notify--test-tmpfile1) + ;; After the rename, we won't get events anymore. + (file-notify--test-read-event) + (delete-directory temporary-file-directory 'recursive)) + (file-notify-rm-watch file-notify--test-desc)) + + ;; Check attribute change. Does not work for cygwin. + (unless (and (eq system-type 'cygwin) + (not (file-remote-p temporary-file-directory))) + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(attribute-change) #'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; w32notify does not distinguish between `changed' and + ;; `attribute-changed'. Under MS Windows 7, we get + ;; four `changed' events, and under MS Windows 10 just + ;; two. Strange. + ((string-equal (file-notify--test-library) "w32notify") + '((changed changed) + (changed changed changed changed))) + ;; For kqueue and in the remote case, `write-region' + ;; raises also an `attribute-changed' event. + ((or (string-equal (file-notify--test-library) "kqueue") + (file-remote-p temporary-file-directory)) + '(attribute-changed attribute-changed attribute-changed)) + (t '(attribute-changed attribute-changed))) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (file-notify--test-read-event) + (set-file-modes file-notify--test-tmpfile 000) + (file-notify--test-read-event) + (set-file-times file-notify--test-tmpfile '(0 0)) + (file-notify--test-read-event) + (delete-file file-notify--test-tmpfile)) + (file-notify-rm-watch file-notify--test-desc)) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup))) + +(file-notify--deftest-remote file-notify-test02-events + "Check file creation/change/removal notifications for remote files.") + +(require 'autorevert) +(setq auto-revert-notify-exclude-dir-regexp "nothing-to-be-excluded" + auto-revert-remote-files t + auto-revert-stop-on-user-input nil) + +(ert-deftest file-notify-test03-autorevert () + "Check autorevert via file notification." + (skip-unless (file-notify--test-local-enabled)) + + ;; `auto-revert-buffers' runs every 5". And we must wait, until the + ;; file has been reverted. + (let ((timeout (if (file-remote-p temporary-file-directory) 60 10)) + buf) + (unwind-protect + (progn + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (setq buf (find-file-noselect file-notify--test-tmpfile)) + (with-current-buffer buf + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (sleep-for 1) + (auto-revert-mode 1) + + ;; `auto-revert-buffers' runs every 5". + (with-timeout (timeout (ignore)) + (while (null auto-revert-notify-watch-descriptor) + (sleep-for 1))) + + ;; Check, that file notification has been used. + (should auto-revert-mode) + (should auto-revert-use-notify) + (should auto-revert-notify-watch-descriptor) + + ;; Modify file. We wait for a second, in order to have + ;; another timestamp. + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (sleep-for 1) + (write-region + "another text" nil file-notify--test-tmpfile nil 'no-message) + + ;; Check, that the buffer has been reverted. + (with-current-buffer (get-buffer-create "*Messages*") + (file-notify--wait-for-events + timeout + (string-match + (format-message "Reverting buffer `%s'." (buffer-name buf)) + (buffer-string)))) + (should (string-match "another text" (buffer-string))) + + ;; Stop file notification. Autorevert shall still work via polling. + (file-notify-rm-watch auto-revert-notify-watch-descriptor) + (file-notify--wait-for-events + timeout (null auto-revert-use-notify)) + (should-not auto-revert-use-notify) + (should-not auto-revert-notify-watch-descriptor) + + ;; Modify file. We wait for two seconds, in order to + ;; have another timestamp. One second seems to be too + ;; short. + (with-current-buffer (get-buffer-create "*Messages*") + (narrow-to-region (point-max) (point-max))) + (sleep-for 2) + (write-region + "foo bla" nil file-notify--test-tmpfile nil 'no-message) + + ;; Check, that the buffer has been reverted. + (with-current-buffer (get-buffer-create "*Messages*") + (file-notify--wait-for-events + timeout + (string-match + (format-message "Reverting buffer `%s'." (buffer-name buf)) + (buffer-string)))) + (should (string-match "foo bla" (buffer-string)))) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (with-current-buffer "*Messages*" (widen)) + (ignore-errors (kill-buffer buf)) + (file-notify--test-cleanup)))) + +(file-notify--deftest-remote file-notify-test03-autorevert + "Check autorevert via file notification for remote files.") + +(ert-deftest file-notify-test04-file-validity () + "Check `file-notify-valid-p' for files." + (skip-unless (file-notify--test-local-enabled)) + + (unwind-protect + (progn + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile '(change) #'ignore))) + (should (file-notify-valid-p file-notify--test-desc)) + ;; After calling `file-notify-rm-watch', the descriptor is not + ;; valid anymore. + (file-notify-rm-watch file-notify--test-desc) + (should-not (file-notify-valid-p file-notify--test-desc)) + (delete-file file-notify--test-tmpfile) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + (progn + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) #'file-notify--test-event-handler))) + (should (file-notify-valid-p file-notify--test-desc)) + (file-notify--test-with-events + ;; There could be one or two `changed' events. + '((changed deleted stopped) + (changed changed deleted stopped)) + (write-region + "another text" nil file-notify--test-tmpfile nil 'no-message) + (file-notify--test-read-event) + (delete-file file-notify--test-tmpfile)) + ;; After deleting the file, the descriptor is not valid anymore. + (should-not (file-notify-valid-p file-notify--test-desc)) + (file-notify-rm-watch file-notify--test-desc) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + (let ((temporary-file-directory + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-desc + (file-notify-add-watch + temporary-file-directory + '(change) #'file-notify--test-event-handler))) + (should (file-notify-valid-p file-notify--test-desc)) + (file-notify--test-with-events + (cond + ;; w32notify does not raise `deleted' and `stopped' events + ;; for the watched directory. + ((string-equal (file-notify--test-library) "w32notify") + '(created changed deleted)) + ;; There are two `deleted' events, for the file and for the + ;; directory. Except for cygwin and kqueue. And cygwin + ;; does not raise a `changed' event. + ((eq system-type 'cygwin) + '(created deleted stopped)) + ((string-equal (file-notify--test-library) "kqueue") + '(created changed deleted stopped)) + (t '(created changed deleted deleted stopped))) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (file-notify--test-read-event) + (delete-directory temporary-file-directory t)) + ;; After deleting the parent directory, the descriptor must + ;; not be valid anymore. + (should-not (file-notify-valid-p file-notify--test-desc)) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup))) + +(file-notify--deftest-remote file-notify-test04-file-validity + "Check `file-notify-valid-p' via file notification for remote files.") + +(ert-deftest file-notify-test05-dir-validity () + "Check `file-notify-valid-p' for directories." + (skip-unless (file-notify--test-local-enabled)) + + (unwind-protect + (progn + (should + (setq file-notify--test-tmpfile + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile '(change) #'ignore))) + (should (file-notify-valid-p file-notify--test-desc)) + ;; After removing the watch, the descriptor must not be valid + ;; anymore. + (file-notify-rm-watch file-notify--test-desc) + (file-notify--wait-for-events + (file-notify--test-timeout) + (not (file-notify-valid-p file-notify--test-desc))) + (should-not (file-notify-valid-p file-notify--test-desc)) + (delete-directory file-notify--test-tmpfile t) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + (progn + (should + (setq file-notify--test-tmpfile + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile '(change) #'ignore))) + (should (file-notify-valid-p file-notify--test-desc)) + ;; After deleting the directory, the descriptor must not be + ;; valid anymore. + (delete-directory file-notify--test-tmpfile t) + (file-notify--wait-for-events + (file-notify--test-timeout) + (not (file-notify-valid-p file-notify--test-desc))) + (should-not (file-notify-valid-p file-notify--test-desc)) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup))) + +(file-notify--deftest-remote file-notify-test05-dir-validity + "Check `file-notify-valid-p' via file notification for remote directories.") + +(ert-deftest file-notify-test06-many-events () + "Check that events are not dropped." + :tags '(:expensive-test) + (skip-unless (file-notify--test-local-enabled)) + + (should + (setq file-notify--test-tmpfile + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) #'file-notify--test-event-handler))) + (unwind-protect + (let ((n 1000) + source-file-list target-file-list + (default-directory file-notify--test-tmpfile)) + (dotimes (i n) + ;; It matters which direction we rename, at least for + ;; kqueue. This backend parses directories in alphabetic + ;; order (x%d before y%d). So we rename into both directions. + (if (zerop (mod i 2)) + (progn + (push (expand-file-name (format "x%d" i)) source-file-list) + (push (expand-file-name (format "y%d" i)) target-file-list)) + (push (expand-file-name (format "y%d" i)) source-file-list) + (push (expand-file-name (format "x%d" i)) target-file-list))) + (file-notify--test-with-events (make-list (+ n n) 'created) + (let ((source-file-list source-file-list) + (target-file-list target-file-list)) + (while (and source-file-list target-file-list) + (file-notify--test-read-event) + (write-region "" nil (pop source-file-list) nil 'no-message) + (file-notify--test-read-event) + (write-region "" nil (pop target-file-list) nil 'no-message)))) + (file-notify--test-with-events + (cond + ;; w32notify fires both `deleted' and `renamed' events. + ((string-equal (file-notify--test-library) "w32notify") + (let (r) + (dotimes (_i n r) + (setq r (append '(deleted renamed) r))))) + ;; cygwin fires `changed' and `deleted' events, sometimes + ;; in random order. + ((eq system-type 'cygwin) + (let (r) + (dotimes (_i n (cons :random r)) + (setq r (append '(changed deleted) r))))) + (t (make-list n 'renamed))) + (let ((source-file-list source-file-list) + (target-file-list target-file-list)) + (while (and source-file-list target-file-list) + (file-notify--test-read-event) + (rename-file (pop source-file-list) (pop target-file-list) t)))) + (file-notify--test-with-events (make-list n 'deleted) + (dolist (file target-file-list) + (file-notify--test-read-event) + (delete-file file))) + (delete-directory file-notify--test-tmpfile) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup))) + +(file-notify--deftest-remote file-notify-test06-many-events + "Check that events are not dropped for remote directories.") + +(ert-deftest file-notify-test07-backup () + "Check that backup keeps file notification." + (skip-unless (file-notify--test-local-enabled)) + + (unwind-protect + (progn + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) #'file-notify--test-event-handler))) + (should (file-notify-valid-p file-notify--test-desc)) + (file-notify--test-with-events + ;; There could be one or two `changed' events. + '((changed) + (changed changed)) + ;; There shouldn't be any problem, because the file is kept. + (with-temp-buffer + (let ((buffer-file-name file-notify--test-tmpfile) + (make-backup-files t) + (backup-by-copying t) + (kept-new-versions 1) + (delete-old-versions t)) + (insert "another text") + (save-buffer)))) + ;; After saving the buffer, the descriptor is still valid. + (should (file-notify-valid-p file-notify--test-desc)) + (delete-file file-notify--test-tmpfile) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + ;; It doesn't work for kqueue, because we don't use an implicit + ;; directory monitor. + (unless (string-equal (file-notify--test-library) "kqueue") + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) #'file-notify--test-event-handler))) + (should (file-notify-valid-p file-notify--test-desc)) + (file-notify--test-with-events + (cond + ;; On cygwin we only get the `changed' event. + ((eq system-type 'cygwin) '(changed)) + (t '(renamed created changed))) + ;; The file is renamed when creating a backup. It shall + ;; still be watched. + (with-temp-buffer + (let ((buffer-file-name file-notify--test-tmpfile) + (make-backup-files t) + (backup-by-copying nil) + (backup-by-copying-when-mismatch nil) + (kept-new-versions 1) + (delete-old-versions t)) + (insert "another text") + (save-buffer)))) + ;; After saving the buffer, the descriptor is still valid. + (should (file-notify-valid-p file-notify--test-desc)) + (delete-file file-notify--test-tmpfile) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup))) + +(file-notify--deftest-remote file-notify-test07-backup + "Check that backup keeps file notification for remote files.") + +(ert-deftest file-notify-test08-watched-file-in-watched-dir () + "Watches a directory and a file in that directory separately. +Checks that the callbacks are only called with events with +descriptors that were issued when registering the watches. This +test caters for the situation in bug#22736 where the callback for +the directory received events for the file with the descriptor of +the file watch." + :tags '(:expensive-test) + (skip-unless (file-notify--test-local-enabled)) + + ;; A directory to be watched. + (should + (setq file-notify--test-tmpfile + (make-temp-file "file-notify-test-parent" t))) + ;; A file to be watched. + (should + (setq file-notify--test-tmpfile1 + (let ((temporary-file-directory file-notify--test-tmpfile)) + (file-notify--test-make-temp-name)))) + (write-region "any text" nil file-notify--test-tmpfile1 nil 'no-message) + (unwind-protect + (cl-flet (;; Directory monitor. + (dir-callback (event) + (let ((file-notify--test-desc file-notify--test-desc1)) + (file-notify--test-event-handler event))) + ;; File monitor. + (file-callback (event) + (let ((file-notify--test-desc file-notify--test-desc2)) + (file-notify--test-event-handler event)))) + (should + (setq file-notify--test-desc1 + (file-notify-add-watch + file-notify--test-tmpfile + '(change) #'dir-callback))) + (should + (setq file-notify--test-desc2 + (file-notify-add-watch + file-notify--test-tmpfile1 + '(change) #'file-callback))) + (should (file-notify-valid-p file-notify--test-desc1)) + (should (file-notify-valid-p file-notify--test-desc2)) + (should-not (equal file-notify--test-desc1 file-notify--test-desc2)) + (let ((n 100)) + ;; Run the test. + (file-notify--test-with-events + ;; There could be one or two `changed' events. + (list + ;; cygwin. + (append + '(:random) + (make-list (/ n 2) 'changed) + (make-list (/ n 2) 'created) + (make-list (/ n 2) 'changed)) + (append + '(:random) + ;; Directory monitor and file monitor. + (make-list (/ n 2) 'changed) + (make-list (/ n 2) 'changed) + ;; Just the directory monitor. + (make-list (/ n 2) 'created) + (make-list (/ n 2) 'changed)) + (append + '(:random) + ;; Directory monitor and file monitor. + (make-list (/ n 2) 'changed) + (make-list (/ n 2) 'changed) + (make-list (/ n 2) 'changed) + (make-list (/ n 2) 'changed) + ;; Just the directory monitor. + (make-list (/ n 2) 'created) + (make-list (/ n 2) 'changed))) + (dotimes (i n) + (file-notify--test-read-event) + (if (zerop (mod i 2)) + (write-region + "any text" nil file-notify--test-tmpfile1 t 'no-message) + (let ((temporary-file-directory file-notify--test-tmpfile)) + (write-region + "any text" nil + (file-notify--test-make-temp-name) nil 'no-message)))))) + + ;; If we delete the file, the directory monitor shall still be + ;; active. We receive the `deleted' event from both the + ;; directory and the file monitor. The `stopped' event is + ;; from the file monitor. It's undecided in which order the + ;; the directory and the file monitor are triggered. + (file-notify--test-with-events '(:random deleted deleted stopped) + (delete-file file-notify--test-tmpfile1)) + (should (file-notify-valid-p file-notify--test-desc1)) + (should-not (file-notify-valid-p file-notify--test-desc2)) + + ;; Now we delete the directory. + (file-notify--test-with-events + (cond + ;; In kqueue and for cygwin, just one `deleted' event for + ;; the directory is received. + ((or (eq system-type 'cygwin) + (string-equal (file-notify--test-library) "kqueue")) + '(deleted stopped)) + (t (append + ;; The directory monitor raises a `deleted' event for + ;; every file contained in the directory, we must + ;; count them. + (make-list + (length + (directory-files + file-notify--test-tmpfile nil + directory-files-no-dot-files-regexp 'nosort)) + 'deleted) + ;; The events of the directory itself. + (cond + ;; w32notify does not raise `deleted' and `stopped' + ;; events for the watched directory. + ((string-equal (file-notify--test-library) "w32notify") '()) + (t '(deleted stopped)))))) + (delete-directory file-notify--test-tmpfile 'recursive)) + (should-not (file-notify-valid-p file-notify--test-desc1)) + (should-not (file-notify-valid-p file-notify--test-desc2)) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup))) + +(file-notify--deftest-remote file-notify-test08-watched-file-in-watched-dir + "Check `file-notify-test08-watched-file-in-watched-dir' for remote files.") + +(ert-deftest file-notify-test09-sufficient-resources () + "Check that file notification does not use too many resources." + :tags '(:expensive-test) + (skip-unless (file-notify--test-local-enabled)) + ;; This test is intended for kqueue only. + (skip-unless (string-equal (file-notify--test-library) "kqueue")) + + (should + (setq file-notify--test-tmpfile + (make-temp-file "file-notify-test-parent" t))) + (unwind-protect + (let ((temporary-file-directory file-notify--test-tmpfile) + descs) + (should-error + (while t + ;; We watch directories, because we want to reach the upper + ;; limit. Watching a file might not be sufficient, because + ;; most of the libraries implement this as watching the + ;; upper directory. + (setq file-notify--test-tmpfile1 + (make-temp-file "file-notify-test-parent" t) + descs + (cons + (should + (file-notify-add-watch + file-notify--test-tmpfile1 '(change) #'ignore)) + descs))) + :type 'file-notify-error) + ;; Remove watches. If we don't do it prior removing + ;; directories, Emacs crashes in batch mode. + (dolist (desc descs) + (file-notify-rm-watch desc)) + ;; Remove directories. + (delete-directory file-notify--test-tmpfile 'recursive) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup))) + +(file-notify--deftest-remote file-notify-test09-sufficient-resources + "Check `file-notify-test09-sufficient-resources' for remote files.") + +(defun file-notify-test-all (&optional interactive) + "Run all tests for \\[file-notify]." + (interactive "p") + (if interactive + (ert-run-tests-interactively "^file-notify-") + (ert-run-tests-batch "^file-notify-"))) + +;; TODO: + +;; * kqueue does not send all expected `deleted' events. Maybe due to +;; the missing directory monitor. +;; * For w32notify, no `deleted' and `stopped' events arrive when a +;; directory is removed. +;; * For cygwin and w32notify, no `attribute-changed' events arrive. +;; They send `changed' events instead. +;; * cygwin does not send all expected `changed' and `deleted' events. +;; Probably due to timing issues. + +(provide 'file-notify-tests) +;;; filenotify-tests.el ends here diff --cc test/lisp/files-tests.el index 6fbe993bfdd,00000000000..9d456c512b0 mode 100644,000000..100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@@ -1,247 -1,0 +1,247 @@@ +;;; files-tests.el --- tests for files.el. + - ;; Copyright (C) 2012-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2012-2017 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) + +;; Set to t if the local variable was set, `query' if the query was +;; triggered. +(defvar files-test-result nil) + +(defvar files-test-safe-result nil) +(put 'files-test-safe-result 'safe-local-variable 'booleanp) + +(defun files-test-fun1 () + (setq files-test-result t)) + +;; Test combinations: +;; `enable-local-variables' t, nil, :safe, :all, or something else. +;; `enable-local-eval' t, nil, or something else. + +(defvar files-test-local-variable-data + ;; Unsafe eval form + '((("eval: (files-test-fun1)") + (t t (eq files-test-result t)) + (t nil (eq files-test-result nil)) + (t maybe (eq files-test-result 'query)) + (nil t (eq files-test-result nil)) + (nil nil (eq files-test-result nil)) + (nil maybe (eq files-test-result nil)) + (:safe t (eq files-test-result nil)) + (:safe nil (eq files-test-result nil)) + (:safe maybe (eq files-test-result nil)) + (:all t (eq files-test-result t)) + (:all nil (eq files-test-result nil)) + (:all maybe (eq files-test-result t)) ; This combination is ambiguous. + (maybe t (eq files-test-result 'query)) + (maybe nil (eq files-test-result nil)) + (maybe maybe (eq files-test-result 'query))) + ;; Unsafe local variable value + (("files-test-result: t") + (t t (eq files-test-result 'query)) + (t nil (eq files-test-result 'query)) + (t maybe (eq files-test-result 'query)) + (nil t (eq files-test-result nil)) + (nil nil (eq files-test-result nil)) + (nil maybe (eq files-test-result nil)) + (:safe t (eq files-test-result nil)) + (:safe nil (eq files-test-result nil)) + (:safe maybe (eq files-test-result nil)) + (:all t (eq files-test-result t)) + (:all nil (eq files-test-result t)) + (:all maybe (eq files-test-result t)) + (maybe t (eq files-test-result 'query)) + (maybe nil (eq files-test-result 'query)) + (maybe maybe (eq files-test-result 'query))) + ;; Safe local variable + (("files-test-safe-result: t") + (t t (eq files-test-safe-result t)) + (t nil (eq files-test-safe-result t)) + (t maybe (eq files-test-safe-result t)) + (nil t (eq files-test-safe-result nil)) + (nil nil (eq files-test-safe-result nil)) + (nil maybe (eq files-test-safe-result nil)) + (:safe t (eq files-test-safe-result t)) + (:safe nil (eq files-test-safe-result t)) + (:safe maybe (eq files-test-safe-result t)) + (:all t (eq files-test-safe-result t)) + (:all nil (eq files-test-safe-result t)) + (:all maybe (eq files-test-safe-result t)) + (maybe t (eq files-test-result 'query)) + (maybe nil (eq files-test-result 'query)) + (maybe maybe (eq files-test-result 'query))) + ;; Safe local variable with unsafe value + (("files-test-safe-result: 1") + (t t (eq files-test-result 'query)) + (t nil (eq files-test-result 'query)) + (t maybe (eq files-test-result 'query)) + (nil t (eq files-test-safe-result nil)) + (nil nil (eq files-test-safe-result nil)) + (nil maybe (eq files-test-safe-result nil)) + (:safe t (eq files-test-safe-result nil)) + (:safe nil (eq files-test-safe-result nil)) + (:safe maybe (eq files-test-safe-result nil)) + (:all t (eq files-test-safe-result 1)) + (:all nil (eq files-test-safe-result 1)) + (:all maybe (eq files-test-safe-result 1)) + (maybe t (eq files-test-result 'query)) + (maybe nil (eq files-test-result 'query)) + (maybe maybe (eq files-test-result 'query)))) + "List of file-local variable tests. +Each list element should have the form + + (LOCAL-VARS-LIST . TEST-LIST) + +where LOCAL-VARS-LISTS should be a list of local variable +definitions (strings) and TEST-LIST is a list of tests to +perform. Each entry of TEST-LIST should have the form + + (ENABLE-LOCAL-VARIABLES ENABLE-LOCAL-EVAL FORM) + +where ENABLE-LOCAL-VARIABLES is the value to assign to +`enable-local-variables', ENABLE-LOCAL-EVAL is the value to +assign to `enable-local-eval', and FORM is a desired `should' +form.") + +(defun file-test--do-local-variables-test (str test-settings) + (with-temp-buffer + (insert str) + (setq files-test-result nil + files-test-safe-result nil) + (let ((enable-local-variables (nth 0 test-settings)) + (enable-local-eval (nth 1 test-settings)) + ;; Prevent any dir-locals file interfering with the tests. + (enable-dir-local-variables nil) + (files-test-queried nil)) + (hack-local-variables) + (eval (nth 2 test-settings))))) + +(ert-deftest files-test-local-variables () + "Test the file-local variables implementation." + (unwind-protect + (progn + (defadvice hack-local-variables-confirm (around files-test activate) + (setq files-test-result 'query) + nil) + (dolist (test files-test-local-variable-data) + (let ((str (concat "text\n\n;; Local Variables:\n;; " + (mapconcat 'identity (car test) "\n;; ") + "\n;; End:\n"))) + (dolist (subtest (cdr test)) + (should (file-test--do-local-variables-test str subtest)))))) + (ad-disable-advice 'hack-local-variables-confirm 'around 'files-test))) + +(defvar files-test-bug-18141-file + (expand-file-name "data/files-bug18141.el.gz" (getenv "EMACS_TEST_DIRECTORY")) + "Test file for bug#18141.") + +(ert-deftest files-test-bug-18141 () + "Test for http://debbugs.gnu.org/18141 ." + (skip-unless (executable-find "gzip")) + (let ((tempfile (make-temp-file "files-test-bug-18141" nil ".gz"))) + (unwind-protect + (progn + (copy-file files-test-bug-18141-file tempfile t) + (with-current-buffer (find-file-noselect tempfile) + (set-buffer-modified-p t) + (save-buffer) + (should (eq buffer-file-coding-system 'iso-2022-7bit-unix)))) + (delete-file tempfile)))) + + +;; Stop the above "Local Var..." confusing Emacs. + + +(ert-deftest files-test-bug-21454 () + "Test for http://debbugs.gnu.org/21454 ." + :expected-result :failed + (let ((input-result + '(("/foo/bar//baz/:/bar/foo/baz//" nil ("/foo/bar/baz/" "/bar/foo/baz/")) + ("/foo/bar/:/bar/qux/:/qux/foo" nil ("/foo/bar/" "/bar/qux/" "/qux/foo/")) + ("//foo/bar/:/bar/qux/:/qux/foo/" nil ("/foo/bar/" "/bar/qux/" "/qux/foo/")) + ("/foo/bar/:/bar/qux/:/qux/foo/" nil ("/foo/bar/" "/bar/qux/" "/qux/foo/")) + ("/foo//bar/:/bar/qux/:/qux/foo/" nil ("/foo/bar/" "/bar/qux/" "/qux/foo/")) + ("/foo//bar/:/bar/qux/:/qux/foo" nil ("/foo/bar/" "/bar/qux/" "/qux/foo/")) + ("/foo/bar" "$FOO/baz/:/qux/foo/" ("/foo/bar/baz/" "/qux/foo/")) + ("//foo/bar/" "$FOO/baz/:/qux/foo/" ("/foo/bar/baz/" "/qux/foo/")))) + (foo-env (getenv "FOO")) + (bar-env (getenv "BAR"))) + (unwind-protect + (dolist (test input-result) + (let ((foo (nth 0 test)) + (bar (nth 1 test)) + (res (nth 2 test))) + (setenv "FOO" foo) + (if bar + (progn + (setenv "BAR" bar) + (should (equal res (parse-colon-path (getenv "BAR"))))) + (should (equal res (parse-colon-path "$FOO")))))) + (setenv "FOO" foo-env) + (setenv "BAR" bar-env)))) + +(ert-deftest files-test--save-buffers-kill-emacs--confirm-kill-processes () + "Test that `save-buffers-kill-emacs' honors +`confirm-kill-processes'." + (cl-letf* ((yes-or-no-p-prompts nil) + ((symbol-function #'yes-or-no-p) + (lambda (prompt) + (push prompt yes-or-no-p-prompts) + nil)) + (kill-emacs-args nil) + ((symbol-function #'kill-emacs) + (lambda (&optional arg) (push arg kill-emacs-args))) + (process + (make-process + :name "sleep" + :command (list + (expand-file-name invocation-name invocation-directory) + "-batch" "-Q" "-eval" "(sleep-for 1000)"))) + (confirm-kill-processes nil)) + (save-buffers-kill-emacs) + (kill-process process) + (should-not yes-or-no-p-prompts) + (should (equal kill-emacs-args '(nil))))) + +(ert-deftest files-test-read-file-in-~ () + "Test file prompting in directory named '~'. +If we are in a directory named '~', the default value should not +be $HOME." + (cl-letf (((symbol-function 'completing-read) + (lambda (_prompt _coll &optional _pred _req init _hist def _) + (or def init))) + (dir (make-temp-file "read-file-name-test" t))) + (unwind-protect + (let ((subdir (expand-file-name "./~/" dir))) + (make-directory subdir t) + (with-temp-buffer + (setq default-directory subdir) + (should-not (equal + (expand-file-name (read-file-name "File: ")) + (expand-file-name "~/"))) + ;; Don't overquote either! + (setq default-directory (concat "/:" subdir)) + (should-not (equal + (expand-file-name (read-file-name "File: ")) + (concat "/:/:" subdir))))) + (delete-directory dir 'recursive)))) + +(provide 'files-tests) +;;; files-tests.el ends here diff --cc test/lisp/gnus/gnus-tests.el index 6801ce69a3e,00000000000..47c49b38c42 mode 100644,000000..100644 --- a/test/lisp/gnus/gnus-tests.el +++ b/test/lisp/gnus/gnus-tests.el @@@ -1,35 -1,0 +1,35 @@@ +;;; gnus-tests.el --- Wrapper for the Gnus tests + - ;; Copyright (C) 2011-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2011-2017 Free Software Foundation, Inc. + +;; Author: Teodor Zlatanov + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This file should contain nothing but requires for all the Gnus +;; tests that are not standalone. + +;;; Code: +;; registry.el is required by gnus-registry.el but this way we're explicit. +(eval-when-compile (require 'cl)) + +(require 'registry) +(require 'gnus-registry) + +(provide 'gnus-tests) +;;; gnus-tests.el ends here diff --cc test/lisp/gnus/message-tests.el index 13c15e33b27,00000000000..40367251420 mode 100644,000000..100644 --- a/test/lisp/gnus/message-tests.el +++ b/test/lisp/gnus/message-tests.el @@@ -1,103 -1,0 +1,103 @@@ +;;; message-mode-tests.el --- Tests for message-mode -*- lexical-binding: t; -*- + - ;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2017 Free Software Foundation, Inc. + +;; Author: João Távora + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This file contains tests for message-mode. + +;;; Code: + +(require 'message) +(require 'ert) +(require 'ert-x) + +(ert-deftest message-mode-propertize () + (with-temp-buffer + (unwind-protect + (let (message-auto-save-directory) + (message-mode) + (insert "here's an opener (\n" + "here's a sad face :-(\n" + "> here's citing someone with an opener (\n" + "and here's a closer ") + (let ((last-command-event ?\))) + (ert-simulate-command '(self-insert-command 1))) + ;; Auto syntax propertization doesn't kick in until + ;; parse-sexp-lookup-properties is set. + (setq-local parse-sexp-lookup-properties t) + (backward-sexp) + (should (string= "here's an opener " + (buffer-substring-no-properties + (line-beginning-position) + (point)))) + (forward-sexp) + (should (string= "and here's a closer )" + (buffer-substring-no-properties + (line-beginning-position) + (point))))) + (set-buffer-modified-p nil)))) + + +(ert-deftest message-strip-subject-trailing-was () + (cl-letf (((symbol-function 'message-talkative-question) nil)) + (with-temp-buffer + (let ((no-was "Re: Foo ") + (with-was "Re: Foo \t (was: Bar ) ") + (stripped-was "Re: Foo") + reply) + + ;; Test unconditional stripping + (setq-local message-subject-trailing-was-query t) + (should (string= no-was (message-strip-subject-trailing-was no-was))) + (should (string= stripped-was + (message-strip-subject-trailing-was with-was))) + + ;; Test asking + (setq-local message-subject-trailing-was-query 'ask) + (fset 'message-talkative-question + (lambda (_ question show text) + (should (string= "Strip `(was: )' in subject? " + question)) + (should show) + (should (string-match + (concat + "Strip `(was: )' in subject " + "and use the new one instead\\?\n\n" + "Current subject is: \"\\(.*\\)\"\n\n" + "New subject would be: \"\\(.*\\)\"\n\n" + "See the variable " + "`message-subject-trailing-was-query' " + "to get rid of this query.") + text)) + (should (string= (match-string 1 text) with-was)) + (should (string= (match-string 2 text) stripped-was)) + reply)) + (message-strip-subject-trailing-was with-was) + (should (string= with-was + (message-strip-subject-trailing-was with-was))) + (setq reply t) + (should (string= stripped-was + (message-strip-subject-trailing-was with-was))))))) + + +(provide 'message-mode-tests) + +;;; message-mode-tests.el ends here diff --cc test/lisp/imenu-tests.el index b6e0f604d0e,00000000000..480368fcbb6 mode 100644,000000..100644 --- a/test/lisp/imenu-tests.el +++ b/test/lisp/imenu-tests.el @@@ -1,88 -1,0 +1,88 @@@ +;;; imenu-tests.el --- Test suite for imenu. + - ;; Copyright (C) 2013-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + +;; Author: Masatake YAMATO +;; Keywords: tools convenience + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'imenu) + +;; (imenu-simple-scan-deftest-gather-strings-from-list +;; '(nil t 'a (0 . "x") ("c" . "d") ("a" 0 "b") )) +;; => ("b" "a" "d" "c" "x") +(defun imenu-simple-scan-deftest-gather-strings-from-list(input) + "Gather strings from INPUT, a list." + (let ((result ())) + (while input + (cond + ((stringp input) + (setq result (cons input result) + input nil)) + ((atom input) + (setq input nil)) + ((listp (car input)) + (setq result (append + (imenu-simple-scan-deftest-gather-strings-from-list (car input)) + result) + input (cdr input))) + ((stringp (car input)) + (setq result (cons (car input) result) + input (cdr input))) + (t + (setq input (cdr input))))) + result)) + +(defmacro imenu-simple-scan-deftest (name doc major-mode content expected-items) + "Generate an ert test for mode-own imenu expression. +Run `imenu-create-index-function' at the buffer which content is +CONTENT with MAJOR-MODE. A generated test runs `imenu-create-index-function' +at the buffer which content is CONTENT with MAJOR-MODE. Then it compares a list +of strings which are picked up from the result with EXPECTED-ITEMS." + (let ((xname (intern (concat "imenu-simple-scan-deftest-" (symbol-name name))))) + `(ert-deftest ,xname () + ,doc + (with-temp-buffer + (insert ,content) + (funcall ',major-mode) + (let ((result-items (sort (imenu-simple-scan-deftest-gather-strings-from-list + (funcall imenu-create-index-function)) + #'string-lessp)) + (expected-items (sort (copy-sequence ,expected-items) #'string-lessp))) + (should (equal result-items expected-items)) + ))))) + +(imenu-simple-scan-deftest sh "Test imenu expression for sh-mode." sh-mode "a() +{ +} +function b +{ +} +function c() +{ +} +function ABC_D() +{ +} +" '("a" "b" "c" "ABC_D")) + +(provide 'imenu-tests) + +;;; imenu-tests.el ends here diff --cc test/lisp/info-xref-tests.el index bc3115042bc,00000000000..9ae07c33fd9 mode 100644,000000..100644 --- a/test/lisp/info-xref-tests.el +++ b/test/lisp/info-xref-tests.el @@@ -1,147 -1,0 +1,147 @@@ +;;; info-xref.el --- tests for info-xref.el + - ;; Copyright (C) 2013-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'info-xref) + +(defun info-xref-test-internal (body result) + "Body of a basic info-xref ert test. +BODY is a string from an info buffer. +RESULT is a list (NBAD NGOOD NUNAVAIL)." + (get-buffer-create info-xref-output-buffer) + (setq info-xref-xfile-alist nil) + (require 'info) + (let ((Info-directory-list '(".")) + Info-additional-directory-list) + (info-xref-with-output + (with-temp-buffer + (insert body) + (info-xref-check-buffer)))) + (should (equal result (list info-xref-bad info-xref-good info-xref-unavail))) + ;; If there was an error, we can leave this around. + (kill-buffer info-xref-output-buffer)) + +(ert-deftest info-xref-test-node-crossref () + "Test parsing of @xref{node,crossref,,manual} with Texinfo 4/5." + (info-xref-test-internal " +*Note crossref: (manual-foo)node. Texinfo 4/5 format with crossref. +" '(0 0 1))) + +(ert-deftest info-xref-test-node-4 () + "Test parsing of @xref{node,,,manual} with Texinfo 4." + (info-xref-test-internal " +*Note node: (manual-foo)node. Texinfo 4 format with no crossref. +" '(0 0 1))) + +(ert-deftest info-xref-test-node-5 () + "Test parsing of @xref{node,,,manual} with Texinfo 5." + (info-xref-test-internal " +*Note (manual-foo)node::. Texinfo 5 format with no crossref. +" '(0 0 1))) + +;; TODO Easier to have static data files in the repo? +(defun info-xref-test-write-file (file body) + "Write BODY to texi FILE." + (with-temp-buffer + (insert "\ +\\input texinfo +@setfilename " + (format "%s.info\n" (file-name-sans-extension file)) + "\ +@settitle test + +@ifnottex +@node Top +@top test +@end ifnottex + +@menu +* Chapter One:: +@end menu + +@node Chapter One +@chapter Chapter One + +text. + +" + body + "\ +@bye +" + ) + (write-region nil nil file nil 'silent)) + (should (equal 0 (call-process "makeinfo" file)))) + +(ert-deftest info-xref-test-makeinfo () + "Test that info-xref can parse basic makeinfo output." + (skip-unless (executable-find "makeinfo")) + (let ((tempfile (make-temp-file "info-xref-test" nil ".texi")) + (tempfile2 (make-temp-file "info-xref-test2" nil ".texi")) + (errflag t)) + (unwind-protect + (progn + ;; tempfile contains xrefs to various things, including tempfile2. + (info-xref-test-write-file + tempfile + (concat "\ +@xref{nodename,,,missing,Missing Manual}. + +@xref{nodename,crossref,title,missing,Missing Manual}. + +@xref{Chapter One}. + +@xref{Chapter One,Something}. + +" + (format "@xref{Chapter One,,,%s,Present Manual}.\n" + (file-name-sans-extension (file-name-nondirectory + tempfile2))))) + ;; Something for tempfile to xref to. + (info-xref-test-write-file tempfile2 "") + (require 'info) + (save-window-excursion + (let ((Info-directory-list + (list + (or (file-name-directory tempfile) "."))) + Info-additional-directory-list) + (info-xref-check (format "%s.info" (file-name-sans-extension + tempfile)))) + (should (equal (list info-xref-bad info-xref-good + info-xref-unavail) + '(0 1 2))) + (setq errflag nil) + ;; If there was an error, we can leave this around. + (kill-buffer info-xref-output-buffer))) + ;; Useful diagnostic in case of problems. + (if errflag + (with-temp-buffer + (call-process "makeinfo" nil t nil "--version") + (message "%s" (buffer-string)))) + (mapc 'delete-file (list tempfile tempfile2 + (format "%s.info" (file-name-sans-extension + tempfile)) + (format "%s.info" (file-name-sans-extension + tempfile2))))))) + +;;; info-xref.el ends here diff --cc test/lisp/international/mule-util-tests.el index 9846aa13295,00000000000..356ee33232f mode 100644,000000..100644 --- a/test/lisp/international/mule-util-tests.el +++ b/test/lisp/international/mule-util-tests.el @@@ -1,84 -1,0 +1,84 @@@ +;;; mule-util --- tests for international/mule-util.el + - ;; Copyright (C) 2002-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2002-2017 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'mule-util) + +(defconst mule-util-test-truncate-data + '((("" 0) . "") + (("x" 1) . "x") + (("xy" 1) . "x") + (("xy" 2 1) . "y") + (("xy" 0) . "") + (("xy" 3) . "xy") + (("中" 0) . "") + (("中" 1) . "") + (("中" 2) . "中") + (("中" 1 nil ? ) . " ") + (("中文" 3 1 ? ) . " ") + (("x中x" 2) . "x") + (("x中x" 3) . "x中") + (("x中x" 3) . "x中") + (("x中x" 4 1) . "中x") + (("kor한e글an" 8 1 ? ) . "or한e글") + (("kor한e글an" 7 2 ? ) . "r한e ") + (("" 0 nil nil "...") . "") + (("x" 3 nil nil "...") . "x") + (("中" 3 nil nil "...") . "中") + (("foo" 3 nil nil "...") . "foo") + (("foo" 2 nil nil "...") . "fo") ;; XEmacs failure? + (("foobar" 6 0 nil "...") . "foobar") + (("foobarbaz" 6 nil nil "...") . "foo...") + (("foobarbaz" 7 2 nil "...") . "ob...") + (("foobarbaz" 9 3 nil "...") . "barbaz") + (("こhんeにlちlはo" 15 1 ? t) . " hんeにlちlはo") + (("こhんeにlちlはo" 14 1 ? t) . " hんeにlち...") + (("x" 3 nil nil "粵語") . "x") + (("中" 2 nil nil "粵語") . "中") + (("中" 1 nil ?x "粵語") . "x") ;; XEmacs error + (("中文" 3 nil ? "粵語") . "中 ") ;; XEmacs error + (("foobarbaz" 4 nil nil "粵語") . "粵語") + (("foobarbaz" 5 nil nil "粵語") . "f粵語") + (("foobarbaz" 6 nil nil "粵語") . "fo粵語") + (("foobarbaz" 8 3 nil "粵語") . "b粵語") + (("こhんeにlちlはo" 14 4 ?x "日本語") . "xeに日本語") + (("こhんeにlちlはo" 13 4 ?x "日本語") . "xex日本語") + ) + "Test data for `truncate-string-to-width'.") + +(defun mule-util-test-truncate-create (n) + "Create a test for element N of the `mule-util-test-truncate-data' constant." + (let ((testname (intern (format "mule-util-test-truncate-%.2d" n))) + (testdoc (format "Test element %d of `mule-util-test-truncate-data'." + n)) + (testdata (nth n mule-util-test-truncate-data))) + (eval + `(ert-deftest ,testname () + ,testdoc + (should (equal (apply 'truncate-string-to-width ',(car testdata)) + ,(cdr testdata))))))) + +(dotimes (i (length mule-util-test-truncate-data)) + (mule-util-test-truncate-create i)) + +;;; mule-util.el ends here diff --cc test/lisp/isearch-tests.el index 52f312d0b97,00000000000..e5cae8237e1 mode 100644,000000..100644 --- a/test/lisp/isearch-tests.el +++ b/test/lisp/isearch-tests.el @@@ -1,40 -1,0 +1,40 @@@ +;;; isearch-tests.el --- Tests for isearch.el -*- lexical-binding: t; -*- + - ;; Copyright (C) 2013-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + +;; Author: Artur Malabarba + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'ert) + +(ert-deftest isearch--test-update () + (with-temp-buffer + (setq isearch--current-buffer (current-buffer))) + (with-temp-buffer + (isearch-update) + (should (equal isearch--current-buffer (current-buffer))))) + +(ert-deftest isearch--test-done () + ;; Normal operation. + (isearch-update) + (isearch-done) + (should-not isearch--current-buffer) + ;; Bug #21091: let `isearch-done' work without `isearch-update'. + (isearch-done)) + +(provide 'isearch-tests) +;;; isearch-tests.el ends here diff --cc test/lisp/json-tests.el index 78cebb45eed,00000000000..66fc25ad1c0 mode 100644,000000..100644 --- a/test/lisp/json-tests.el +++ b/test/lisp/json-tests.el @@@ -1,320 -1,0 +1,320 @@@ +;;; json-tests.el --- Test suite for json.el + - ;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2017 Free Software Foundation, Inc. + +;; Author: Dmitry Gutov + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'ert) +(require 'json) + +(defmacro json-tests--with-temp-buffer (content &rest body) + "Create a temporary buffer with CONTENT and evaluate BODY there. +Point is moved to beginning of the buffer." + (declare (indent 1)) + `(with-temp-buffer + (insert ,content) + (goto-char (point-min)) + ,@body)) + +;;; Utilities + +(ert-deftest test-json-join () + (should (equal (json-join '() ", ") "")) + (should (equal (json-join '("a" "b" "c") ", ") "a, b, c"))) + +(ert-deftest test-json-alist-p () + (should (json-alist-p '())) + (should (json-alist-p '((a 1) (b 2) (c 3)))) + (should (json-alist-p '((:a 1) (:b 2) (:c 3)))) + (should (json-alist-p '(("a" 1) ("b" 2) ("c" 3)))) + (should-not (json-alist-p '(:a :b :c))) + (should-not (json-alist-p '(:a 1 :b 2 :c 3))) + (should-not (json-alist-p '((:a 1) (:b 2) 3)))) + +(ert-deftest test-json-plist-p () + (should (json-plist-p '())) + (should (json-plist-p '(:a 1 :b 2 :c 3))) + (should-not (json-plist-p '(a 1 b 2 c 3))) + (should-not (json-plist-p '("a" 1 "b" 2 "c" 3))) + (should-not (json-plist-p '(:a :b :c))) + (should-not (json-plist-p '((:a 1) (:b 2) (:c 3))))) + +(ert-deftest test-json-plist-reverse () + (should (equal (json--plist-reverse '()) '())) + (should (equal (json--plist-reverse '(:a 1)) '(:a 1))) + (should (equal (json--plist-reverse '(:a 1 :b 2 :c 3)) + '(:c 3 :b 2 :a 1)))) + +(ert-deftest test-json-plist-to-alist () + (should (equal (json--plist-to-alist '()) '())) + (should (equal (json--plist-to-alist '(:a 1)) '((:a . 1)))) + (should (equal (json--plist-to-alist '(:a 1 :b 2 :c 3)) + '((:a . 1) (:b . 2) (:c . 3))))) + +(ert-deftest test-json-advance () + (json-tests--with-temp-buffer "{ \"a\": 1 }" + (json-advance 0) + (should (= (point) (point-min))) + (json-advance 3) + (should (= (point) (+ (point-min) 3))))) + +(ert-deftest test-json-peek () + (json-tests--with-temp-buffer "" + (should (eq (json-peek) :json-eof))) + (json-tests--with-temp-buffer "{ \"a\": 1 }" + (should (equal (json-peek) ?{)))) + +(ert-deftest test-json-pop () + (json-tests--with-temp-buffer "" + (should-error (json-pop) :type 'json-end-of-file)) + (json-tests--with-temp-buffer "{ \"a\": 1 }" + (should (equal (json-pop) ?{)) + (should (= (point) (+ (point-min) 1))))) + +(ert-deftest test-json-skip-whitespace () + (json-tests--with-temp-buffer "\t\r\n\f\b { \"a\": 1 }" + (json-skip-whitespace) + (should (equal (char-after (point)) ?{)))) + +;;; Paths + +(ert-deftest test-json-path-to-position-with-objects () + (let* ((json-string "{\"foo\": {\"bar\": {\"baz\": \"value\"}}}") + (matched-path (json-path-to-position 32 json-string))) + (should (equal (plist-get matched-path :path) '("foo" "bar" "baz"))) + (should (equal (plist-get matched-path :match-start) 25)) + (should (equal (plist-get matched-path :match-end) 32)))) + +(ert-deftest test-json-path-to-position-with-arrays () + (let* ((json-string "{\"foo\": [\"bar\", [\"baz\"]]}") + (matched-path (json-path-to-position 20 json-string))) + (should (equal (plist-get matched-path :path) '("foo" 1 0))) + (should (equal (plist-get matched-path :match-start) 18)) + (should (equal (plist-get matched-path :match-end) 23)))) + +(ert-deftest test-json-path-to-position-no-match () + (let* ((json-string "{\"foo\": {\"bar\": \"baz\"}}") + (matched-path (json-path-to-position 5 json-string))) + (should (null matched-path)))) + +;;; Keywords + +(ert-deftest test-json-read-keyword () + (json-tests--with-temp-buffer "true" + (should (json-read-keyword "true"))) + (json-tests--with-temp-buffer "true" + (should-error + (json-read-keyword "false") :type 'json-unknown-keyword)) + (json-tests--with-temp-buffer "foo" + (should-error + (json-read-keyword "foo") :type 'json-unknown-keyword))) + +(ert-deftest test-json-encode-keyword () + (should (equal (json-encode-keyword t) "true")) + (should (equal (json-encode-keyword json-false) "false")) + (should (equal (json-encode-keyword json-null) "null"))) + +;;; Numbers + +(ert-deftest test-json-read-number () + (json-tests--with-temp-buffer "3" + (should (= (json-read-number) 3))) + (json-tests--with-temp-buffer "-5" + (should (= (json-read-number) -5))) + (json-tests--with-temp-buffer "123.456" + (should (= (json-read-number) 123.456))) + (json-tests--with-temp-buffer "1e3" + (should (= (json-read-number) 1e3))) + (json-tests--with-temp-buffer "2e+3" + (should (= (json-read-number) 2e3))) + (json-tests--with-temp-buffer "3E3" + (should (= (json-read-number) 3e3))) + (json-tests--with-temp-buffer "1e-7" + (should (= (json-read-number) 1e-7))) + (json-tests--with-temp-buffer "abc" + (should-error (json-read-number) :type 'json-number-format))) + +(ert-deftest test-json-encode-number () + (should (equal (json-encode-number 3) "3")) + (should (equal (json-encode-number -5) "-5")) + (should (equal (json-encode-number 123.456) "123.456"))) + +;; Strings + +(ert-deftest test-json-read-escaped-char () + (json-tests--with-temp-buffer "\\\"" + (should (equal (json-read-escaped-char) ?\")))) + +(ert-deftest test-json-read-string () + (json-tests--with-temp-buffer "\"foo \\\"bar\\\"\"" + (should (equal (json-read-string) "foo \"bar\""))) + (json-tests--with-temp-buffer "\"abcαβγ\"" + (should (equal (json-read-string) "abcαβγ"))) + (json-tests--with-temp-buffer "\"\\nasd\\u0444\\u044b\\u0432fgh\\t\"" + (should (equal (json-read-string) "\nasdфывfgh\t"))) + (json-tests--with-temp-buffer "foo" + (should-error (json-read-string) :type 'json-string-format))) + +(ert-deftest test-json-encode-string () + (should (equal (json-encode-string "foo") "\"foo\"")) + (should (equal (json-encode-string "a\n\fb") "\"a\\n\\fb\"")) + (should (equal (json-encode-string "\nasdфыв\u001f\u007ffgh\t") + "\"\\nasdфыв\\u001f\u007ffgh\\t\""))) + +(ert-deftest test-json-encode-key () + (should (equal (json-encode-key "foo") "\"foo\"")) + (should (equal (json-encode-key 'foo) "\"foo\"")) + (should (equal (json-encode-key :foo) "\"foo\"")) + (should-error (json-encode-key 5) :type 'json-key-format) + (should-error (json-encode-key ["foo"]) :type 'json-key-format) + (should-error (json-encode-key '("foo")) :type 'json-key-format)) + +;;; Objects + +(ert-deftest test-json-new-object () + (let ((json-object-type 'alist)) + (should (equal (json-new-object) '()))) + (let ((json-object-type 'plist)) + (should (equal (json-new-object) '()))) + (let* ((json-object-type 'hash-table) + (json-object (json-new-object))) + (should (hash-table-p json-object)) + (should (= (hash-table-count json-object) 0)))) + +(ert-deftest test-json-add-to-object () + (let* ((json-object-type 'alist) + (json-key-type nil) + (obj (json-new-object))) + (setq obj (json-add-to-object obj "a" 1)) + (setq obj (json-add-to-object obj "b" 2)) + (should (equal (assq 'a obj) '(a . 1))) + (should (equal (assq 'b obj) '(b . 2)))) + (let* ((json-object-type 'plist) + (json-key-type nil) + (obj (json-new-object))) + (setq obj (json-add-to-object obj "a" 1)) + (setq obj (json-add-to-object obj "b" 2)) + (should (= (plist-get obj :a) 1)) + (should (= (plist-get obj :b) 2))) + (let* ((json-object-type 'hash-table) + (json-key-type nil) + (obj (json-new-object))) + (setq obj (json-add-to-object obj "a" 1)) + (setq obj (json-add-to-object obj "b" 2)) + (should (= (gethash "a" obj) 1)) + (should (= (gethash "b" obj) 2)))) + +(ert-deftest test-json-read-object () + (json-tests--with-temp-buffer "{ \"a\": 1, \"b\": 2 }" + (let ((json-object-type 'alist)) + (should (equal (json-read-object) '((a . 1) (b . 2)))))) + (json-tests--with-temp-buffer "{ \"a\": 1, \"b\": 2 }" + (let ((json-object-type 'plist)) + (should (equal (json-read-object) '(:a 1 :b 2))))) + (json-tests--with-temp-buffer "{ \"a\": 1, \"b\": 2 }" + (let* ((json-object-type 'hash-table) + (hash-table (json-read-object))) + (should (= (gethash "a" hash-table) 1)) + (should (= (gethash "b" hash-table) 2)))) + (json-tests--with-temp-buffer "{ \"a\": 1 \"b\": 2 }" + (should-error (json-read-object) :type 'json-object-format))) + +(ert-deftest test-json-encode-hash-table () + (let ((hash-table (make-hash-table)) + (json-encoding-object-sort-predicate 'string<) + (json-encoding-pretty-print nil)) + (puthash :a 1 hash-table) + (puthash :b 2 hash-table) + (puthash :c 3 hash-table) + (should (equal (json-encode hash-table) + "{\"a\":1,\"b\":2,\"c\":3}")))) + +(ert-deftest json-encode-simple-alist () + (let ((json-encoding-pretty-print nil)) + (should (equal (json-encode '((a . 1) (b . 2))) + "{\"a\":1,\"b\":2}")))) + +(ert-deftest test-json-encode-plist () + (let ((plist '(:a 1 :b 2)) + (json-encoding-pretty-print nil)) + (should (equal (json-encode plist) "{\"a\":1,\"b\":2}")))) + +(ert-deftest test-json-encode-plist-with-sort-predicate () + (let ((plist '(:c 3 :a 1 :b 2)) + (json-encoding-object-sort-predicate 'string<) + (json-encoding-pretty-print nil)) + (should (equal (json-encode plist) "{\"a\":1,\"b\":2,\"c\":3}")))) + +(ert-deftest test-json-encode-alist-with-sort-predicate () + (let ((alist '((:c . 3) (:a . 1) (:b . 2))) + (json-encoding-object-sort-predicate 'string<) + (json-encoding-pretty-print nil)) + (should (equal (json-encode alist) "{\"a\":1,\"b\":2,\"c\":3}")))) + +(ert-deftest test-json-encode-list () + (let ((json-encoding-pretty-print nil)) + (should (equal (json-encode-list '(:a 1 :b 2)) + "{\"a\":1,\"b\":2}")) + (should (equal (json-encode-list '((:a . 1) (:b . 2))) + "{\"a\":1,\"b\":2}")) + (should (equal (json-encode-list '(1 2 3 4)) "[1,2,3,4]")))) + +;;; Arrays + +(ert-deftest test-json-read-array () + (let ((json-array-type 'vector)) + (json-tests--with-temp-buffer "[1, 2, \"a\", \"b\"]" + (should (equal (json-read-array) [1 2 "a" "b"])))) + (let ((json-array-type 'list)) + (json-tests--with-temp-buffer "[1, 2, \"a\", \"b\"]" + (should (equal (json-read-array) '(1 2 "a" "b"))))) + (json-tests--with-temp-buffer "[1 2]" + (should-error (json-read-array) :type 'json-error))) + +(ert-deftest test-json-encode-array () + (let ((json-encoding-pretty-print nil)) + (should (equal (json-encode-array [1 2 "a" "b"]) + "[1,2,\"a\",\"b\"]")))) + +;;; Reader + +(ert-deftest test-json-read () + (json-tests--with-temp-buffer "{ \"a\": 1 }" + ;; We don't care exactly what the return value is (that is tested + ;; in `test-json-read-object'), but it should parse without error. + (should (json-read))) + (json-tests--with-temp-buffer "" + (should-error (json-read) :type 'json-end-of-file)) + (json-tests--with-temp-buffer "xxx" + (should-error (json-read) :type 'json-readtable-error))) + +(ert-deftest test-json-read-from-string () + (let ((json-string "{ \"a\": 1 }")) + (json-tests--with-temp-buffer json-string + (should (equal (json-read-from-string json-string) + (json-read)))))) + +;;; JSON encoder + +(ert-deftest test-json-encode () + (should (equal (json-encode "foo") "\"foo\"")) + (with-temp-buffer + (should-error (json-encode (current-buffer)) :type 'json-error))) + +(provide 'json-tests) +;;; json-tests.el ends here diff --cc test/lisp/mail/rmail-tests.el index 2f18372146a,00000000000..6cf9053bc0d mode 100644,000000..100644 --- a/test/lisp/mail/rmail-tests.el +++ b/test/lisp/mail/rmail-tests.el @@@ -1,35 -1,0 +1,35 @@@ +;;; rmail-tests.el --- Test suite. -*- lexical-binding: t -*- + - ;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2017 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: +(require 'ert) +(require 'rmail) + + +(ert-deftest rmail-autoload () + "Tests to see whether reftex-auc has been autoloaded" + (should + (fboundp 'rmail-edit-current-message)) + (should + (autoloadp + (symbol-function + 'rmail-edit-current-message)))) + +(provide 'rmail-tests) +;; rmail-tests.el ends here diff --cc test/lisp/man-tests.el index b1cc4437256,00000000000..b9f47f50c20 mode 100644,000000..100644 --- a/test/lisp/man-tests.el +++ b/test/lisp/man-tests.el @@@ -1,118 -1,0 +1,118 @@@ +;;; man-tests.el --- Test suite for man. + - ;; Copyright (C) 2013-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + +;; Author: Wolfgang Jenkner +;; Keywords: help, internal, unix + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'man) + +(defconst man-tests-parse-man-k-tests + '(;; GNU/Linux: man-db-2.6.1 + ("\ +sin (3) - sine function +sinf (3) - sine function +sinl (3) - sine function" + . (#("sin(3)" 0 6 (help-echo "sine function")) #("sinf(3)" 0 7 (help-echo "sine function")) #("sinl(3)" 0 7 (help-echo "sine function")))) + ;; GNU/Linux: man-1.6g + ("\ +sin (3) - sine function +sinf [sin] (3) - sine function +sinl [sin] (3) - sine function" + . (#("sin(3)" 0 6 (help-echo "sine function")) #("sinf(3)" 0 7 (help-echo "sine function")) #("sinl(3)" 0 7 (help-echo "sine function")))) + ;; FreeBSD 9 + ("\ +sin(3), sinf(3), sinl(3) - sine functions" + . (#("sin(3)" 0 6 (help-echo "sine functions")) #("sinf(3)" 0 7 (help-echo "sine functions")) #("sinl(3)" 0 7 (help-echo "sine functions")))) + ;; SunOS, Solaris + ;; http://docs.oracle.com/cd/E19455-01/805-6331/usradm-7/index.html + ;; SunOS 4 + ("\ +tset, reset (1) - establish or restore terminal characteristics" + . (#("tset(1)" 0 7 (help-echo "establish or restore terminal characteristics")) #("reset(1)" 0 8 (help-echo "establish or restore terminal characteristics")))) + ;; SunOS 5.7, Solaris + ("\ +reset tset (1b) - establish or restore terminal characteristics +tset tset (1b) - establish or restore terminal characteristics" + . (#("reset(1b)" 0 8 (help-echo "establish or restore terminal characteristics")) #("tset(1b)" 0 7 (help-echo "establish or restore terminal characteristics")))) + ;; Minix 3 + ;; http://www.minix3.org/manpages/html5/whatis.html + ("\ +cawf, nroff (1) - C version of the nroff-like, Amazingly Workable (text) Formatter +whatis (5) - database of online manual pages" + . (#("cawf(1)" 0 7 (help-echo "C version of the nroff-like, Amazingly Workable (text) Formatter")) #("nroff(1)" 0 8 (help-echo "C version of the nroff-like, Amazingly Workable (text) Formatter")) #("whatis(5)" 0 9 (help-echo "database of online manual pages")))) + ;; HP-UX + ;; http://docstore.mik.ua/manuals/hp-ux/en/B2355-60130/man.1.html + ;; Assuming that the line break in the zgrep description was + ;; introduced by the man page formatting. + ("\ +grep, egrep, fgrep (1) - search a file for a pattern +zgrep(1) - search possibly compressed files for a regular expression" + . (#("grep(1)" 0 7 (help-echo "search a file for a pattern")) #("egrep(1)" 0 8 (help-echo "search a file for a pattern")) #("fgrep(1)" 0 8 (help-echo "search a file for a pattern")) #("zgrep(1)" 0 8 (help-echo "search possibly compressed files for a regular expression")))) + ;; AIX + ;; http://pic.dhe.ibm.com/infocenter/aix/v7r1/topic/com.ibm.aix.cmds/doc/aixcmds6/whatis.htm + ("\ +ls(1) -Displays the contents of a directory." + . (#("ls(1)" 0 5 (help-echo "Displays the contents of a directory.")))) + ;; https://www.ibm.com/developerworks/mydeveloperworks/blogs/cgaix/entry/catman_0703_102_usr_lbin_mkwhatis_the_error_number_is_1?lang=en + ("\ +loopmount(1) - Associate an image file to a loopback device." + . (#("loopmount(1)" 0 12 (help-echo "Associate an image file to a loopback device.")))) + ) + "List of tests for `Man-parse-man-k'. +Each element is a cons cell whose car is a string containing +man -k output. That should result in the table which is stored +in the cdr of the element.") + +(defun man-tests-name-equal-p (name description string) + (and (equal name string) + (not (next-single-property-change 0 'help-echo string)) + (equal (get-text-property 0 'help-echo string) description))) + +(defun man-tests-parse-man-k-test-case (test) + (let ((temp-buffer (get-buffer-create " *test-man*")) + (man-k-output (car test))) + (unwind-protect + (save-window-excursion + (with-current-buffer temp-buffer + (erase-buffer) + (insert man-k-output) + (let ((result (Man-parse-man-k)) + (checklist (cdr test))) + (while (and checklist result + (man-tests-name-equal-p + (car checklist) + (get-text-property 0 'help-echo + (car checklist)) + (pop result))) + (pop checklist)) + (and (null checklist) (null result))))) + (and (buffer-name temp-buffer) + (kill-buffer temp-buffer))))) + +(ert-deftest man-tests () + "Test man." + (dolist (test man-tests-parse-man-k-tests) + (should (man-tests-parse-man-k-test-case test)))) + +(provide 'man-tests) + +;;; man-tests.el ends here diff --cc test/lisp/minibuffer-tests.el index 0f2abf45673,00000000000..efed8f8bed4 mode 100644,000000..100644 --- a/test/lisp/minibuffer-tests.el +++ b/test/lisp/minibuffer-tests.el @@@ -1,46 -1,0 +1,46 @@@ +;;; completion-tests.el --- Tests for completion functions -*- lexical-binding: t; -*- + - ;; Copyright (C) 2013-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(eval-when-compile (require 'cl-lib)) + +(ert-deftest completion-test1 () + (with-temp-buffer + (cl-flet* ((test/completion-table (string pred action) + (if (eq action 'lambda) + nil + "test: ")) + (test/completion-at-point () + (list (copy-marker (point-min)) + (copy-marker (point)) + #'test/completion-table))) + (let ((completion-at-point-functions (list #'test/completion-at-point))) + (insert "TEST") + (completion-at-point) + (should (equal (buffer-string) + "test: ")))))) + +(provide 'completion-tests) +;;; completion-tests.el ends here diff --cc test/lisp/net/dbus-tests.el index 12be1637109,00000000000..525709b92e7 mode 100644,000000..100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@@ -1,182 -1,0 +1,182 @@@ +;;; dbus-tests.el --- Tests of D-Bus integration into Emacs + - ;; Copyright (C) 2013-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + +;; Author: Michael Albinus + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Code: + +(require 'ert) +(require 'dbus) + +(setq dbus-debug nil) + +(defvar dbus--test-enabled-session-bus + (and (featurep 'dbusbind) + (dbus-ignore-errors (dbus-get-unique-name :session))) + "Check, whether we are registered at the session bus.") + +(defvar dbus--test-enabled-system-bus + (and (featurep 'dbusbind) + (dbus-ignore-errors (dbus-get-unique-name :system))) + "Check, whether we are registered at the system bus.") + +(defun dbus--test-availability (bus) + "Test availability of D-Bus BUS." + (should (dbus-list-names bus)) + (should (dbus-list-activatable-names bus)) + (should (dbus-list-known-names bus)) + (should (dbus-get-unique-name bus))) + +(ert-deftest dbus-test00-availability-session () + "Test availability of D-Bus `:session'." + :expected-result (if dbus--test-enabled-session-bus :passed :failed) + (dbus--test-availability :session)) + +(ert-deftest dbus-test00-availability-system () + "Test availability of D-Bus `:system'." + :expected-result (if dbus--test-enabled-system-bus :passed :failed) + (dbus--test-availability :system)) + +(ert-deftest dbus-test01-type-conversion () + "Check type conversion functions." + (let ((ustr "0123abc_xyz\x01\xff") + (mstr "Grüß Göttin")) + (should + (string-equal + (dbus-byte-array-to-string (dbus-string-to-byte-array "")) "")) + (should + (string-equal + (dbus-byte-array-to-string (dbus-string-to-byte-array ustr)) ustr)) + (should + (string-equal + (dbus-byte-array-to-string (dbus-string-to-byte-array mstr) 'multibyte) + mstr)) + ;; Should not work for multibyte strings. + (should-not + (string-equal + (dbus-byte-array-to-string (dbus-string-to-byte-array mstr)) mstr)) + + (should + (string-equal + (dbus-unescape-from-identifier (dbus-escape-as-identifier "")) "")) + (should + (string-equal + (dbus-unescape-from-identifier (dbus-escape-as-identifier ustr)) ustr)) + ;; Should not work for multibyte strings. + (should-not + (string-equal + (dbus-unescape-from-identifier (dbus-escape-as-identifier mstr)) mstr)))) + +(defun dbus--test-register-service (bus) + "Check service registration at BUS." + ;; Cleanup. + (dbus-ignore-errors (dbus-unregister-service bus dbus-service-emacs)) + + ;; Register an own service. + (should (eq (dbus-register-service bus dbus-service-emacs) :primary-owner)) + (should (member dbus-service-emacs (dbus-list-known-names bus))) + (should (eq (dbus-register-service bus dbus-service-emacs) :already-owner)) + (should (member dbus-service-emacs (dbus-list-known-names bus))) + + ;; Unregister the service. + (should (eq (dbus-unregister-service bus dbus-service-emacs) :released)) + (should-not (member dbus-service-emacs (dbus-list-known-names bus))) + (should (eq (dbus-unregister-service bus dbus-service-emacs) :non-existent)) + (should-not (member dbus-service-emacs (dbus-list-known-names bus))) + + ;; `dbus-service-dbus' is reserved for the BUS itself. + (should-error (dbus-register-service bus dbus-service-dbus)) + (should-error (dbus-unregister-service bus dbus-service-dbus))) + +(ert-deftest dbus-test02-register-service-session () + "Check service registration at `:session' bus." + (skip-unless (and dbus--test-enabled-session-bus + (dbus-register-service :session dbus-service-emacs))) + (dbus--test-register-service :session) + + (let ((service "org.freedesktop.Notifications")) + (when (member service (dbus-list-known-names :session)) + ;; Cleanup. + (dbus-ignore-errors (dbus-unregister-service :session service)) + + (should (eq (dbus-register-service :session service) :in-queue)) + (should (eq (dbus-unregister-service :session service) :released)) + + (should + (eq (dbus-register-service :session service :do-not-queue) :exists)) + (should (eq (dbus-unregister-service :session service) :not-owner))))) + +(ert-deftest dbus-test02-register-service-system () + "Check service registration at `:system' bus." + (skip-unless (and dbus--test-enabled-system-bus + (dbus-register-service :system dbus-service-emacs))) + (dbus--test-register-service :system)) + +(ert-deftest dbus-test02-register-service-own-bus () + "Check service registration with an own bus. +This includes initialization and closing the bus." + ;; Start bus. + (let ((output + (ignore-errors + (shell-command-to-string "dbus-launch --sh-syntax"))) + bus pid) + (skip-unless (stringp output)) + (when (string-match "DBUS_SESSION_BUS_ADDRESS='\\(.+\\)';" output) + (setq bus (match-string 1 output))) + (when (string-match "DBUS_SESSION_BUS_PID=\\([[:digit:]]+\\);" output) + (setq pid (match-string 1 output))) + (unwind-protect + (progn + (skip-unless + (dbus-ignore-errors + (and bus pid + (featurep 'dbusbind) + (dbus-init-bus bus) + (dbus-get-unique-name bus) + (dbus-register-service bus dbus-service-emacs)))) + ;; Run the test. + (dbus--test-register-service bus)) + + ;; Save exit. + (when pid (call-process "kill" nil nil nil pid))))) + +(ert-deftest dbus-test03-peer-interface () + "Check `dbus-interface-peer' methods." + (skip-unless + (and dbus--test-enabled-session-bus + (dbus-register-service :session dbus-service-emacs) + ;; "GetMachineId" is not implemented (yet). When it returns a + ;; value, another D-Bus client like dbus-monitor is reacting + ;; on `dbus-interface-peer'. We cannot test then. + (not + (dbus-ignore-errors + (dbus-call-method + :session dbus-service-emacs dbus-path-dbus + dbus-interface-peer "GetMachineId" :timeout 100))))) + + (should (dbus-ping :session dbus-service-emacs 100)) + (dbus-unregister-service :session dbus-service-emacs) + (should-not (dbus-ping :session dbus-service-emacs 100))) + +(defun dbus-test-all (&optional interactive) + "Run all tests for \\[dbus]." + (interactive "p") + (funcall + (if interactive 'ert-run-tests-interactively 'ert-run-tests-batch) "^dbus")) + +(provide 'dbus-tests) +;;; dbus-tests.el ends here diff --cc test/lisp/net/newsticker-tests.el index d8531083e60,00000000000..56064f781de mode 100644,000000..100644 --- a/test/lisp/net/newsticker-tests.el +++ b/test/lisp/net/newsticker-tests.el @@@ -1,168 -1,0 +1,168 @@@ +;;; newsticker-testsuite.el --- Test suite for newsticker. + - ;; Copyright (C) 2003-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2003-2017 Free Software Foundation, Inc. + +;; Author: Ulf Jasper +;; Keywords: News, RSS, Atom + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'newsticker) + +;; ====================================================================== +;; Tests for newsticker-backend +;; ====================================================================== +(ert-deftest newsticker--guid () + "Test for `newsticker--guid-*'. +Signals an error if something goes wrong." + (should (string= "blah" (newsticker--guid-to-string "blah"))) + (should (string= "myguid" (newsticker--guid '("title1" "description1" "link1" + nil 'new 42 nil nil + ((guid () "myguid"))))))) + +(ert-deftest newsticker--cache-contains () + "Test for `newsticker--cache-contains'." + (let ((newsticker--cache '((feed1 + ("title1" "description1" "link1" nil 'new 42 + nil nil ((guid () "myguid"))))))) + (newsticker--guid-to-string + (assoc 'guid (newsticker--extra '("title1" "description1" + "link1" nil 'new 42 nil nil + ((guid "myguid")))))) + (should (newsticker--cache-contains newsticker--cache 'feed1 "WRONGTITLE" + "description1" "link1" 'new "myguid")) + (should (not (newsticker--cache-contains newsticker--cache 'feed1 "title1" + "description1" "link1" 'new + "WRONG GUID"))) + (should (newsticker--cache-contains newsticker--cache 'feed1 "title1" + "description1" "link1" 'new "myguid"))) + (let ((newsticker--cache '((feed1 + ("title1" "description1" "link1" nil 'new 42 + nil nil ((guid () "myguid1"))) + ("title1" "description1" "link1" nil 'new 42 + nil nil ((guid () "myguid2"))))))) + (should (not (newsticker--cache-contains newsticker--cache 'feed1 "title1" + "description1" "link1" 'new + "myguid"))) + (should (string= "myguid1" + (newsticker--guid (newsticker--cache-contains + newsticker--cache 'feed1 "title1" + "description1" "link1" 'new + "myguid1")))) + (should (string= "myguid2" + (newsticker--guid (newsticker--cache-contains + newsticker--cache 'feed1 "title1" + "description1" "link1" 'new + "myguid2")))))) + +(defun newsticker-tests--decode-iso8601-date (input expected) + "Actually test `newsticker--decode-iso8601-date'. +Apply to INPUT and compare with EXPECTED." + (let ((result (format-time-string "%Y-%m-%dT%H:%M:%S" + (newsticker--decode-iso8601-date input) + t))) + (should (string= result expected)))) + +(ert-deftest newsticker--decode-iso8601-date () + "Test `newsticker--decode-iso8601-date'." + (newsticker-tests--decode-iso8601-date "2004" + "2004-01-01T00:00:00") + (newsticker-tests--decode-iso8601-date "2004-09" + "2004-09-01T00:00:00") + (newsticker-tests--decode-iso8601-date "2004-09-17" + "2004-09-17T00:00:00") + (newsticker-tests--decode-iso8601-date "2004-09-17T05:09" + "2004-09-17T05:09:00") + (newsticker-tests--decode-iso8601-date "2004-09-17T05:09:49" + "2004-09-17T05:09:49") + (newsticker-tests--decode-iso8601-date "2004-09-17T05:09:49.123" + "2004-09-17T05:09:49") + (newsticker-tests--decode-iso8601-date "2004-09-17T05:09+01:00" + "2004-09-17T04:09:00") + (newsticker-tests--decode-iso8601-date "2004-09-17T05:09-02:00" + "2004-09-17T07:09:00")) + +(defun newsticker--do-test--decode-rfc822-date (input expected) + "Actually test `newsticker--decode-rfc822-date'. +Apply to INPUT and compare with EXPECTED." + (let ((result (format-time-string "%Y-%m-%dT%H:%M:%S" + (newsticker--decode-rfc822-date input) + t))) + (should (string= result expected)))) + +(ert-deftest newsticker--decode-rfc822-date () + "Test `newsticker--decode-rfc822-date'." + (newsticker--do-test--decode-rfc822-date "Mon, 10 Mar 2008 19:27:52 +0100" + "2008-03-10T18:27:52") + ;;(format-time-string "%d.%m.%y, %H:%M %T%z" + ;;(newsticker--decode-rfc822-date "Mon, 10 Mar 2008 19:27:52 +0200")) + + (newsticker--do-test--decode-rfc822-date "Mon, 10 Mar 2008 19:27:52" + "2008-03-10T19:27:52") + (newsticker--do-test--decode-rfc822-date "Mon, 10 Mar 2008 19:27" + "2008-03-10T19:27:00") + (newsticker--do-test--decode-rfc822-date "10 Mar 2008 19:27" + "2008-03-10T19:27:00") + (newsticker--do-test--decode-rfc822-date "Mon, 10 Mar 2008" + "2008-03-10T00:00:00") + (newsticker--do-test--decode-rfc822-date "10 Mar 2008" + "2008-03-10T00:00:00") + (newsticker--do-test--decode-rfc822-date "Sat, 01 Dec 2007 00:05:00 +0100" + "2007-11-30T23:05:00") + (newsticker--do-test--decode-rfc822-date "Sun, 30 Dec 2007 18:58:13 +0100" + "2007-12-30T17:58:13")) + +;; ====================================================================== +;; Tests for newsticker-treeview +;; ====================================================================== +(ert-deftest newsticker--group-manage-orphan-feeds () + "Test `newsticker--group-manage-orphan-feeds'. +Signals an error if something goes wrong." + (let ((newsticker-groups '("Feeds")) + (newsticker-url-list-defaults nil) + (newsticker-url-list '(("feed1") ("feed2") ("feed3")))) + (newsticker--group-manage-orphan-feeds) + (should (equal '("Feeds" "feed3" "feed2" "feed1") + newsticker-groups)))) + +(ert-deftest newsticker--group-find-parent-group () + "Test `newsticker--group-find-parent-group'." + (let ((newsticker-groups '("g1" "f1a" ("g2" "f2" ("g3" "f3a" "f3b")) "f1b"))) + ;; feeds + (should (equal "g1" (car (newsticker--group-find-parent-group "f1a")))) + (should (equal "g1" (car (newsticker--group-find-parent-group "f1b")))) + (should (equal "g2" (car (newsticker--group-find-parent-group "f2")))) + (should (equal "g3" (car (newsticker--group-find-parent-group "f3b")))) + ;; groups + (should (equal "g1" (car (newsticker--group-find-parent-group "g2")))) + (should (equal "g2" (car (newsticker--group-find-parent-group "g3")))))) + +(ert-deftest newsticker--group-do-rename-group () + "Test `newsticker--group-do-rename-group'." + (let ((newsticker-groups '("g1" "f1a" ("g2" "f2" ("g3" "f3a" "f3b")) "f1b"))) + (should (equal '("g1" "f1a" ("h2" "f2" ("g3" "f3a" "f3b")) "f1b") + (newsticker--group-do-rename-group "g2" "h2"))) + )) + + +(provide 'newsticker-tests) + +;;; newsticker-tests.el ends here diff --cc test/lisp/net/sasl-scram-rfc-tests.el index 130de240481,00000000000..96cec77c56d mode 100644,000000..100644 --- a/test/lisp/net/sasl-scram-rfc-tests.el +++ b/test/lisp/net/sasl-scram-rfc-tests.el @@@ -1,50 -1,0 +1,50 @@@ +;;; sasl-scram-rfc-tests.el --- tests for SCRAM-SHA-1 -*- lexical-binding: t; -*- + - ;; Copyright (C) 2014-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2014-2017 Free Software Foundation, Inc. + +;; Author: Magnus Henoch + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Test cases from RFC 5802. + +;;; Code: + +(require 'sasl) +(require 'sasl-scram-rfc) + +(ert-deftest sasl-scram-sha-1-test () + ;; The following strings are taken from section 5 of RFC 5802. + (let ((client + (sasl-make-client (sasl-find-mechanism '("SCRAM-SHA-1")) + "user" + "imap" + "localhost")) + (data "r=fyko+d2lbbFgONRv9qkxdawL3rfcNHYJY1ZVvWVs7j,s=QSXCR+Q6sek8bf92,i=4096") + (c-nonce "fyko+d2lbbFgONRv9qkxdawL") + (sasl-read-passphrase + (lambda (_prompt) (copy-sequence "pencil")))) + (sasl-client-set-property client 'c-nonce c-nonce) + (should + (equal + (sasl-scram-sha-1-client-final-message client (vector nil data)) + "c=biws,r=fyko+d2lbbFgONRv9qkxdawL3rfcNHYJY1ZVvWVs7j,p=v0X8v3Bz2T0CJGbJQyF0X+HI4Ts=")) + + ;; This should not throw an error: + (sasl-scram-sha-1-authenticate-server client (vector nil "v=rmF9pqV8S7suAoZWja4dJRkFsKQ= +")))) + +;;; sasl-scram-rfc-tests.el ends here diff --cc test/lisp/obarray-tests.el index 92345b7198e,00000000000..9a2d65d8b41 mode 100644,000000..100644 --- a/test/lisp/obarray-tests.el +++ b/test/lisp/obarray-tests.el @@@ -1,90 -1,0 +1,90 @@@ +;;; obarray-tests.el --- Tests for obarray -*- lexical-binding: t; -*- + - ;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2017 Free Software Foundation, Inc. + +;; Author: Przemysław Wojnowski + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'obarray) +(require 'ert) + +(ert-deftest obarrayp-test () + "Should assert that given object is an obarray." + (should-not (obarrayp 42)) + (should-not (obarrayp "aoeu")) + (should-not (obarrayp '())) + (should-not (obarrayp [])) + (should (obarrayp (make-vector 7 0)))) + +(ert-deftest obarrayp-unchecked-content-test () + "Should fail to check content of passed obarray." + :expected-result :failed + (should-not (obarrayp ["a" "b" "c"])) + (should-not (obarrayp [1 2 3]))) + +(ert-deftest obarray-make-default-test () + (let ((table (obarray-make))) + (should (obarrayp table)) + (should (equal (make-vector 59 0) table)))) + +(ert-deftest obarray-make-with-size-test () + (should-error (obarray-make -1) :type 'wrong-type-argument) + (should-error (obarray-make 0) :type 'wrong-type-argument) + (let ((table (obarray-make 1))) + (should (obarrayp table)) + (should (equal (make-vector 1 0) table)))) + +(ert-deftest obarray-get-test () + (let ((table (obarray-make 3))) + (should-not (obarray-get table "aoeu")) + (intern "aoeu" table) + (should (string= "aoeu" (obarray-get table "aoeu"))))) + +(ert-deftest obarray-put-test () + (let ((table (obarray-make 3))) + (should-not (obarray-get table "aoeu")) + (should (string= "aoeu" (obarray-put table "aoeu"))) + (should (string= "aoeu" (obarray-get table "aoeu"))))) + +(ert-deftest obarray-remove-test () + (let ((table (obarray-make 3))) + (should-not (obarray-get table "aoeu")) + (should-not (obarray-remove table "aoeu")) + (should (string= "aoeu" (obarray-put table "aoeu"))) + (should (string= "aoeu" (obarray-get table "aoeu"))) + (should (obarray-remove table "aoeu")) + (should-not (obarray-get table "aoeu")))) + +(ert-deftest obarray-map-test () + "Should execute function on all elements of obarray." + (let* ((table (obarray-make 3)) + (syms '()) + (collect-names (lambda (sym) (push (symbol-name sym) syms)))) + (obarray-map collect-names table) + (should (null syms)) + (obarray-put table "a") + (obarray-put table "b") + (obarray-put table "c") + (obarray-map collect-names table) + (should (equal (sort syms #'string<) '("a" "b" "c"))))) + +(provide 'obarray-tests) +;;; obarray-tests.el ends here diff --cc test/lisp/progmodes/compile-tests.el index 9f61c20fd5e,00000000000..5c8c9c2a81f mode 100644,000000..100644 --- a/test/lisp/progmodes/compile-tests.el +++ b/test/lisp/progmodes/compile-tests.el @@@ -1,382 -1,0 +1,382 @@@ +;;; compile-tests.el --- Test suite for compile.el. -*- lexical-binding: t; -*- + - ;; Copyright (C) 2011-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2011-2017 Free Software Foundation, Inc. + +;; Author: Chong Yidong +;; Keywords: internal +;; Human-Keywords: internal + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Unit tests for lisp/progmodes/compile.el. + +;;; Code: + +(require 'ert) +(require 'compile) + +(defvar compile-tests--test-regexps-data + ;; The computed column numbers are zero-indexed, so subtract 1 from + ;; what's reported in the string. The end column numbers are for + ;; the character after, so it matches what's reported in the string. + '(;; absoft + ("Error on line 3 of t.f: Execution error unclassifiable statement" + 1 nil 3 "t.f") + ("Line 45 of \"foo.c\": bloofle undefined" + 1 nil 45 "foo.c") + ("error on line 19 of fplot.f: spelling error?" + 1 nil 19 "fplot.f") + ("warning on line 17 of fplot.f: data type is undefined for variable d" + 1 nil 17 "fplot.f") + ;; Ada & Mpatrol + ("foo.adb:61:11: [...] in call to size declared at foo.ads:11" + 1 11 61 "foo.adb") + ("foo.adb:61:11: [...] in call to size declared at foo.ads:11" + 52 nil 11 "foo.ads") + (" 0x8008621 main+16 at error.c:17" + 23 nil 17 "error.c") + ;; aix + ("****** Error number 140 in line 8 of file errors.c ******" + 25 nil 8 "errors.c") + ;; ant + ("[javac] /src/DataBaseTestCase.java:27: unreported exception ..." + 13 nil 27 "/src/DataBaseTestCase.java") + ("[javac] /src/DataBaseTestCase.java:49: warning: finally clause cannot complete normally" + 13 nil 49 "/src/DataBaseTestCase.java") + ("[jikes] foo.java:3:5:7:9: blah blah" + 14 (5 . 10) (3 . 7) "foo.java") + ;; bash + ("a.sh: line 1: ls-l: command not found" + 1 nil 1 "a.sh") + ;; borland + ("Error ping.c 15: Unable to open include file 'sys/types.h'" + 1 nil 15 "ping.c") + ("Warning pong.c 68: Call to function 'func' with no prototype" + 1 nil 68 "pong.c") + ("Error E2010 ping.c 15: Unable to open include file 'sys/types.h'" + 1 nil 15 "ping.c") + ("Warning W1022 pong.c 68: Call to function 'func' with no prototype" + 1 nil 68 "pong.c") + ;; caml + ("File \"foobar.ml\", lines 5-8, characters 20-155: blah blah" + 1 (20 . 156) (5 . 8) "foobar.ml") + ("File \"F:\\ocaml\\sorting.ml\", line 65, characters 2-145:\nWarning 26: unused variable equ." + 1 (2 . 146) 65 "F:\\ocaml\\sorting.ml") + ("File \"/usr/share/gdesklets/display/TargetGauge.py\", line 41, in add_children" + 1 nil 41 "/usr/share/gdesklets/display/TargetGauge.py") + ("File \\lib\\python\\Products\\PythonScripts\\PythonScript.py, line 302, in _exec" + 1 nil 302 "\\lib\\python\\Products\\PythonScripts\\PythonScript.py") + ("File \"/tmp/foo.py\", line 10" + 1 nil 10 "/tmp/foo.py") + ;; clang-include + ("In file included from foo.cpp:2:" + 1 nil 2 "foo.cpp" 0) + ;; cmake cmake-info + ("CMake Error at CMakeLists.txt:23 (hurz):" + 1 nil 23 "CMakeLists.txt") + ("CMake Warning at cmake/modules/UseUG.cmake:73 (find_package):" + 1 nil 73 "cmake/modules/UseUG.cmake") + (" cmake/modules/DuneGridMacros.cmake:19 (include)" + 1 nil 19 "cmake/modules/DuneGridMacros.cmake") + ;; comma + ("\"foo.f\", line 3: Error: syntax error near end of statement" + 1 nil 3 "foo.f") + ("\"vvouch.c\", line 19.5: 1506-046 (S) Syntax error." + 1 5 19 "vvouch.c") + ("\"foo.c\", line 32 pos 1; (E) syntax error; unexpected symbol: \"lossage\"" + 1 1 32 "foo.c") + ("\"foo.adb\", line 2(11): warning: file name does not match ..." + 1 11 2 "foo.adb") + ("\"src/swapping.c\", line 30.34: 1506-342 (W) \"/*\" detected in comment." + 1 34 30 "src/swapping.c") + ;; cucumber + ("Scenario: undefined step # features/cucumber.feature:3" + 29 nil 3 "features/cucumber.feature") + (" /home/gusev/.rvm/foo/bar.rb:500:in `_wrap_assertion'" + 1 nil 500 "/home/gusev/.rvm/foo/bar.rb") + ;; edg-1 edg-2 + ("build/intel/debug/../../../struct.cpp(42): error: identifier \"foo\" is undefined" + 1 nil 42 "build/intel/debug/../../../struct.cpp") + ("build/intel/debug/struct.cpp(44): warning #1011: missing return statement at end of" + 1 nil 44 "build/intel/debug/struct.cpp") + ("build/intel/debug/iptr.h(302): remark #981: operands are evaluated in unspecified order" + 1 nil 302 "build/intel/debug/iptr.h") + (" detected during ... at line 62 of \"build/intel/debug/../../../trace.h\"" + 31 nil 62 "build/intel/debug/../../../trace.h") + ;; epc + ("Error 24 at (2:progran.f90) : syntax error" + 1 nil 2 "progran.f90") + ;; ftnchek + (" Dummy arg W in module SUBA line 8 file arrayclash.f is array" + 32 nil 8 "arrayclash.f") + (" L4 used at line 55 file test/assign.f; never set" + 16 nil 55 "test/assign.f") + ("Warning near line 10 file arrayclash.f: Module contains no executable" + 1 nil 10 "arrayclash.f") + ("Nonportable usage near line 31 col 9 file assign.f: mixed default and explicit" + 24 9 31 "assign.f") + ;; iar + ("\"foo.c\",3 Error[32]: Error message" + 1 nil 3 "foo.c") + ("\"foo.c\",3 Warning[32]: Error message" + 1 nil 3 "foo.c") + ;; ibm + ("foo.c(2:0) : informational EDC0804: Function foo is not referenced." + 1 0 2 "foo.c") + ("foo.c(3:8) : warning EDC0833: Implicit return statement encountered." + 1 8 3 "foo.c") + ("foo.c(5:5) : error EDC0350: Syntax error." + 1 5 5 "foo.c") + ;; irix + ("ccom: Error: foo.c, line 2: syntax error" + 1 nil 2 "foo.c") + ("cc: Severe: /src/Python-2.3.3/Modules/_curses_panel.c, line 17: Cannot find file ..." + 1 nil 17 "/src/Python-2.3.3/Modules/_curses_panel.c") + ("cc: Info: foo.c, line 27: ..." + 1 nil 27 "foo.c") + ("cfe: Warning 712: foo.c, line 2: illegal combination of pointer and ..." + 1 nil 2 "foo.c") + ("cfe: Warning 600: xfe.c: 170: Not in a conditional directive while ..." + 1 nil 170 "xfe.c") + ("/usr/lib/cmplrs/cc/cfe: Error: foo.c: 1: blah blah" + 1 nil 1 "foo.c") + ("/usr/lib/cmplrs/cc/cfe: warning: foo.c: 1: blah blah" + 1 nil 1 "foo.c") + ("foo bar: baz.f, line 27: ..." + 1 nil 27 "baz.f") + ;; java + ("\tat org.foo.ComponentGateway.doGet(ComponentGateway.java:172)" + 5 nil 172 "ComponentGateway.java") + ("\tat javax.servlet.http.HttpServlet.service(HttpServlet.java:740)" + 5 nil 740 "HttpServlet.java") + ("==1332== at 0x4040743C: System::getErrorString() (../src/Lib/System.cpp:217)" + 13 nil 217 "../src/Lib/System.cpp") + ("==1332== by 0x8008621: main (vtest.c:180)" + 13 nil 180 "vtest.c") + ;; jikes-file jikes-line + ("Found 2 semantic errors compiling \"../javax/swing/BorderFactory.java\":" + 1 nil nil "../javax/swing/BorderFactory.java") + ("Issued 1 semantic warning compiling \"java/awt/Toolkit.java\":" + 1 nil nil "java/awt/Toolkit.java") + ;; gcc-include + ("In file included from /usr/include/c++/3.3/backward/warn.h:4," + 1 nil 4 "/usr/include/c++/3.3/backward/warn.h") + (" from /usr/include/c++/3.3/backward/iostream.h:31:0," + 1 0 31 "/usr/include/c++/3.3/backward/iostream.h") + (" from test_clt.cc:1:" + 1 nil 1 "test_clt.cc") + ;; gnu + ("foo.c:8: message" 1 nil 8 "foo.c") + ("../foo.c:8: W: message" 1 nil 8 "../foo.c") + ("/tmp/foo.c:8:warning message" 1 nil 8 "/tmp/foo.c") + ("foo/bar.py:8: FutureWarning message" 1 nil 8 "foo/bar.py") + ("foo.py:8: RuntimeWarning message" 1 nil 8 "foo.py") + ("foo.c:8:I: message" 1 nil 8 "foo.c") + ("foo.c:8.23: note: message" 1 23 8 "foo.c") + ("foo.c:8.23: info: message" 1 23 8 "foo.c") + ("foo.c:8:23:information: message" 1 23 8 "foo.c") + ("foo.c:8.23-45: Informational: message" 1 (23 . 46) (8 . nil) "foo.c") + ("foo.c:8-23: message" 1 nil (8 . 23) "foo.c") + ;; The next one is not in the GNU standards AFAICS. + ;; Here we seem to interpret it as LINE1-LINE2.COL2. + ("foo.c:8-45.3: message" 1 (nil . 4) (8 . 45) "foo.c") + ("foo.c:8.23-9.1: message" 1 (23 . 2) (8 . 9) "foo.c") + ("jade:dbcommon.dsl:133:17:E: missing argument for function call" + 1 17 133 "dbcommon.dsl") + ("G:/cygwin/dev/build-myproj.xml:54: Compiler Adapter 'javac' can't be found." + 1 nil 54 "G:/cygwin/dev/build-myproj.xml") + ("file:G:/cygwin/dev/build-myproj.xml:54: Compiler Adapter 'javac' can't be found." + 1 nil 54 "G:/cygwin/dev/build-myproj.xml") + ("{standard input}:27041: Warning: end of file not at end of a line; newline inserted" + 1 nil 27041 "{standard input}") + ;; Guile + ("In foo.scm:\n" 1 nil nil "foo.scm") + (" 63:4 [call-with-prompt prompt0 ...]" 1 4 63 nil) + ("1038: 1 [main (\"gud-break.scm\")]" 1 1 1038 nil) + ;; lcc + ("E, file.cc(35,52) Illegal operation on pointers" 1 52 35 "file.cc") + ("W, file.cc(36,52) blah blah" 1 52 36 "file.cc") + ;; makepp + ("makepp: Scanning `/foo/bar.c'" 19 nil nil "/foo/bar.c") + ("makepp: warning: bla bla `/foo/bar.c' and `/foo/bar.h'" 27 nil nil "/foo/bar.c") + ("makepp: bla bla `/foo/Makeppfile:12' bla" 18 nil 12 "/foo/Makeppfile") + ("makepp: bla bla `/foo/bar.c' and `/foo/bar.h'" 35 nil nil "/foo/bar.h") + ;; maven + ("FooBar.java:[111,53] no interface expected here" + 1 53 111 "FooBar.java" 2) + (" [ERROR] /Users/cinsk/hello.java:[651,96] ';' expected" + 15 96 651 "/Users/cinsk/hello.java" 2) ;Bug#11517. + ("[WARNING] /foo/bar/Test.java:[27,43] unchecked conversion" + 11 43 27 "/foo/bar/Test.java" 1) ;Bug#20556 + ;; mips-1 mips-2 + ("TrimMask (255) in solomon.c may be indistinguishable from TrimMasks (93) in solomo.c due to truncation" + 11 nil 255 "solomon.c") + ("TrimMask (255) in solomon.c may be indistinguishable from TrimMasks (93) in solomo.c due to truncation" + 70 nil 93 "solomo.c") + ("name defined but never used: LinInt in cmap_calc.c(199)" + 40 nil 199 "cmap_calc.c") + ;; msft + ("keyboard handler.c(537) : warning C4005: 'min' : macro redefinition" + 1 nil 537 "keyboard handler.c") + ("d:\\tmp\\test.c(23) : error C2143: syntax error : missing ';' before 'if'" + 1 nil 23 "d:\\tmp\\test.c") + ("d:\\tmp\\test.c(1145) : see declaration of 'nsRefPtr'" + 1 nil 1145 "d:\\tmp\\test.c") + ("1>test_main.cpp(29): error C2144: syntax error : 'int' should be preceded by ';'" + 3 nil 29 "test_main.cpp") + ("1>test_main.cpp(29): error C4430: missing type specifier - int assumed. Note: C++ does not support default-int" + 3 nil 29 "test_main.cpp") + ;; watcom + ("..\\src\\ctrl\\lister.c(109): Error! E1009: Expecting ';' but found '{'" + 1 nil 109 "..\\src\\ctrl\\lister.c") + ("..\\src\\ctrl\\lister.c(120): Warning! W201: Unreachable code" + 1 nil 120 "..\\src\\ctrl\\lister.c") + ;; oracle + ("Semantic error at line 528, column 5, file erosacqdb.pc:" + 1 5 528 "erosacqdb.pc") + ("Error at line 41, column 10 in file /usr/src/sb/ODBI_BHP.hpp" + 1 10 41 "/usr/src/sb/ODBI_BHP.hpp") + ("PCC-02150: error at line 49, column 27 in file /usr/src/sb/ODBI_dxfgh.pc" + 1 27 49 "/usr/src/sb/ODBI_dxfgh.pc") + ("PCC-00003: invalid SQL Identifier at column name in line 12 of file /usr/src/sb/ODBI_BHP.hpp" + 1 nil 12 "/usr/src/sb/ODBI_BHP.hpp") + ("PCC-00004: mismatched IF/ELSE/ENDIF block at line 27 in file /usr/src/sb/ODBI_BHP.hpp" + 1 nil 27 "/usr/src/sb/ODBI_BHP.hpp") + ("PCC-02151: line 21 column 40 file /usr/src/sb/ODBI_BHP.hpp:" + 1 40 21 "/usr/src/sb/ODBI_BHP.hpp") + ;; perl + ("syntax error at automake line 922, near \"':'\"" + 14 nil 922 "automake") + ("Died at test.pl line 27." + 6 nil 27 "test.pl") + ("store::odrecall('File_A', 'x2') called at store.pm line 90" + 40 nil 90 "store.pm") + ("\t(in cleanup) something bad at foo.pl line 3 during global destruction." + 29 nil 3 "foo.pl") + ("GLib-GObject-WARNING **: /build/buildd/glib2.0-2.14.5/gobject/gsignal.c:1741: instance `0x8206790' has no handler with id `1234' at t-compilation-perl-gtk.pl line 3." + 130 nil 3 "t-compilation-perl-gtk.pl") + ;; php + ("Parse error: parse error, unexpected $ in main.php on line 59" + 1 nil 59 "main.php") + ("Fatal error: Call to undefined function: mysql_pconnect() in db.inc on line 66" + 1 nil 66 "db.inc") + ;; ruby + ("plain-exception.rb:7:in `fun': unhandled exception" + 1 nil 7 "plain-exception.rb") + ("\tfrom plain-exception.rb:3:in `proxy'" 2 nil 3 "plain-exception.rb") + ("\tfrom plain-exception.rb:12" 2 nil 12 "plain-exception.rb") + ;; ruby-Test::Unit + ;; FIXME + (" [examples/test-unit.rb:28:in `here_is_a_deep_assert'" + 5 nil 28 "examples/test-unit.rb") + (" examples/test-unit.rb:19:in `test_a_deep_assert']:" + 6 nil 19 "examples/test-unit.rb") + ("examples/test-unit.rb:10:in `test_assert_raise'" + 1 nil 10 "examples/test-unit.rb") + ;; rxp + ("Error: Mismatched end tag: expected , got \nin unnamed entity at line 71 char 8 of file:///home/reto/test/group.xml" + 1 8 71 "/home/reto/test/group.xml") + ("Warning: Start tag for undeclared element geroup\nin unnamed entity at line 4 char 8 of file:///home/reto/test/group.xml" + 1 8 4 "/home/reto/test/group.xml") + ;; sparc-pascal-file sparc-pascal-line sparc-pascal-example + ("Thu May 14 10:46:12 1992 mom3.p:" + 1 nil nil "mom3.p") + ;; sun + ("cc-1020 CC: REMARK File = CUI_App.h, Line = 735" + 13 nil 735 "CUI_App.h") + ("cc-1070 cc: WARNING File = linkl.c, Line = 38" + 13 nil 38 "linkl.c") + ("cf90-113 f90comp: ERROR NSE, File = Hoved.f90, Line = 16, Column = 3" + 18 3 16 "Hoved.f90") + ;; sun-ada + ("/home3/xdhar/rcds_rc/main.a, line 361, char 6:syntax error: \",\" inserted" + 1 6 361 "/home3/xdhar/rcds_rc/main.a") + ;; 4bsd + ("/usr/src/foo/foo.c(8): warning: w may be used before set" + 1 nil 8 "/usr/src/foo/foo.c") + ("/usr/src/foo/foo.c(9): error: w is used before set" + 1 nil 9 "/usr/src/foo/foo.c") + ("strcmp: variable # of args. llib-lc(359) :: /usr/src/foo/foo.c(8)" + 44 nil 8 "/usr/src/foo/foo.c") + ("bloofle defined( /users/wolfgang/foo.c(4) ), but never used" + 18 nil 4 "/users/wolfgang/foo.c") + ;; perl--Pod::Checker + ;; FIXME + ;; *** ERROR: Spurious text after =cut at line 193 in file foo.pm + ;; *** ERROR: =over on line 37 without closing =back at line EOF in file bar.pm + ;; *** ERROR: =over on line 1 without closing =back (at head1) at line 3 in file x.pod + ;; perl--Test + ("# Failed test 1 in foo.t at line 6" + 1 nil 6 "foo.t") + ;; perl--Test::Harness + ("NOK 1# Test 1 got: \"1234\" (t/foo.t at line 46)" + 1 nil 46 "t/foo.t") + ;; weblint + ("index.html (13:1) Unknown element " + 1 1 13 "index.html")) + "List of tests for `compilation-error-regexp-alist'. +Each element has the form (STR POS COLUMN LINE FILENAME [TYPE]), +where STR is an error string, POS is the position of the error in +STR, COLUMN and LINE are the reported column and line numbers (or +nil) for that error, FILENAME is the reported filename, and TYPE +is 0 for an information message, 1 for a warning, and 2 for an +error. + +LINE can also be of the form (LINE . END-LINE) meaning a range of +lines. COLUMN can also be of the form (COLUMN . END-COLUMN) +meaning a range of columns starting on LINE and ending on +END-LINE, if that matched. TYPE can be left out, in which case +any message type is accepted.") + +(defun compile--test-error-line (test) + (erase-buffer) + (setq compilation-locs (make-hash-table)) + (insert (car test)) + (compilation-parse-errors (point-min) (point-max)) + (let ((msg (get-text-property (nth 1 test) 'compilation-message))) + (should msg) + (let ((loc (compilation--message->loc msg)) + (col (nth 2 test)) + (line (nth 3 test)) + (file (nth 4 test)) + (type (nth 5 test)) + end-col end-line) + (if (consp col) + (setq end-col (cdr col) col (car col))) + (if (consp line) + (setq end-line (cdr line) line (car line))) + (should (equal (compilation--loc->col loc) col)) + (should (equal (compilation--loc->line loc) line)) + (when file + (should (equal (caar (compilation--loc->file-struct loc)) file))) + (when end-col + (should (equal (car (cadr (nth 2 (compilation--loc->file-struct loc)))) + end-col))) + (should (equal (car (nth 2 (compilation--loc->file-struct loc))) + (or end-line line))) + (when type + (should (equal type (compilation--message->type msg))))))) + +(ert-deftest compile-test-error-regexps () + "Test the `compilation-error-regexp-alist' regexps. +The test data is in `compile-tests--test-regexps-data'." + (with-temp-buffer + (font-lock-mode -1) + (mapc #'compile--test-error-line compile-tests--test-regexps-data))) + +;;; compile-tests.el ends here diff --cc test/lisp/progmodes/elisp-mode-tests.el index 12e61cf8d18,00000000000..93c428b2d2b mode 100644,000000..100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@@ -1,676 -1,0 +1,676 @@@ +;;; elisp-mode-tests.el --- Tests for emacs-lisp-mode -*- lexical-binding: t; -*- + - ;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2017 Free Software Foundation, Inc. + +;; Author: Dmitry Gutov +;; Author: Stephen Leake + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'xref) + +;;; Completion + +(defun elisp--test-completions () + (let ((data (elisp-completion-at-point))) + (all-completions (buffer-substring (nth 0 data) (nth 1 data)) + (nth 2 data) + (plist-get (nthcdr 3 data) :predicate)))) + +(ert-deftest elisp-completes-functions () + (with-temp-buffer + (emacs-lisp-mode) + (insert "(ba") + (let ((comps (elisp--test-completions))) + (should (member "backup-buffer" comps)) + (should-not (member "backup-inhibited" comps))))) + +(ert-deftest elisp-completes-variables () + (with-temp-buffer + (emacs-lisp-mode) + (insert "(foo ba") + (let ((comps (elisp--test-completions))) + (should (member "backup-inhibited" comps)) + (should-not (member "backup-buffer" comps))))) + +(ert-deftest elisp-completes-anything-quoted () + (dolist (text '("`(foo ba" "(foo 'ba" + "`(,foo ba" "`,(foo `ba" + "'(foo (ba")) + (with-temp-buffer + (emacs-lisp-mode) + (insert text) + (let ((comps (elisp--test-completions))) + (should (member "backup-inhibited" comps)) + (should (member "backup-buffer" comps)) + (should (member "backup" comps)))))) + +(ert-deftest elisp-completes-variables-unquoted () + (dolist (text '("`(foo ,ba" "`(,(foo ba" "`(,ba")) + (with-temp-buffer + (emacs-lisp-mode) + (insert text) + (let ((comps (elisp--test-completions))) + (should (member "backup-inhibited" comps)) + (should-not (member "backup-buffer" comps)))))) + +(ert-deftest elisp-completes-functions-in-special-macros () + (dolist (text '("(declare-function ba" "(cl-callf2 ba")) + (with-temp-buffer + (emacs-lisp-mode) + (insert text) + (let ((comps (elisp--test-completions))) + (should (member "backup-buffer" comps)) + (should-not (member "backup-inhibited" comps)))))) + +(ert-deftest elisp-completes-functions-after-hash-quote () + (ert-deftest elisp-completes-functions-after-let-bindings () + (with-temp-buffer + (emacs-lisp-mode) + (insert "#'ba") + (let ((comps (elisp--test-completions))) + (should (member "backup-buffer" comps)) + (should-not (member "backup-inhibited" comps)))))) + +(ert-deftest elisp-completes-local-variables () + (with-temp-buffer + (emacs-lisp-mode) + (insert "(let ((bar 1) baz) (foo ba") + (let ((comps (elisp--test-completions))) + (should (member "backup-inhibited" comps)) + (should (member "bar" comps)) + (should (member "baz" comps))))) + +(ert-deftest elisp-completest-variables-in-let-bindings () + (dolist (text '("(let (ba" "(let* ((ba")) + (with-temp-buffer + (emacs-lisp-mode) + (insert text) + (let ((comps (elisp--test-completions))) + (should (member "backup-inhibited" comps)) + (should-not (member "backup-buffer" comps)))))) + +(ert-deftest elisp-completes-functions-after-let-bindings () + (with-temp-buffer + (emacs-lisp-mode) + (insert "(let ((bar 1) (baz 2)) (ba") + (let ((comps (elisp--test-completions))) + (should (member "backup-buffer" comps)) + (should-not (member "backup-inhibited" comps))))) + +;;; xref + +(defun xref-elisp-test-descr-to-target (xref) + "Return an appropriate `looking-at' match string for XREF." + (let* ((loc (xref-item-location xref)) + (type (or (xref-elisp-location-type loc) + 'defun))) + + (cl-case type + (defalias + ;; summary: "(defalias xref)" + ;; target : "(defalias 'xref" + (concat "(defalias '" (substring (xref-item-summary xref) 10 -1))) + + (defun + (let ((summary (xref-item-summary xref)) + (file (xref-elisp-location-file loc))) + (cond + ((string= "c" (file-name-extension file)) + ;; summary: "(defun buffer-live-p)" + ;; target : "DEFUN (buffer-live-p" + (concat + (upcase (substring summary 1 6)) + " (\"" + (substring summary 7 -1) + "\"")) + + (t + (substring summary 0 -1)) + ))) + + (defvar + (let ((summary (xref-item-summary xref)) + (file (xref-elisp-location-file loc))) + (cond + ((string= "c" (file-name-extension file)) + ;; summary: "(defvar system-name)" + ;; target : "DEFVAR_LISP ("system-name", " + ;; summary: "(defvar abbrev-mode)" + ;; target : DEFVAR_PER_BUFFER ("abbrev-mode" + (concat + (upcase (substring summary 1 7)) + (if (bufferp (variable-binding-locus (xref-elisp-location-symbol loc))) + "_PER_BUFFER (\"" + "_LISP (\"") + (substring summary 8 -1) + "\"")) + + (t + (substring summary 0 -1)) + ))) + + (feature + ;; summary: "(feature xref)" + ;; target : "(provide 'xref)" + (concat "(provide '" (substring (xref-item-summary xref) 9 -1))) + + (otherwise + (substring (xref-item-summary xref) 0 -1)) + ))) + + +(defun xref-elisp-test-run (xrefs expected-xrefs) + (should (= (length xrefs) (length expected-xrefs))) + (while xrefs + (let* ((xref (pop xrefs)) + (expected (pop expected-xrefs)) + (expected-xref (or (when (consp expected) (car expected)) expected)) + (expected-source (when (consp expected) (cdr expected)))) + + ;; Downcase the filenames for case-insensitive file systems. + (setf (xref-elisp-location-file (oref xref location)) + (downcase (xref-elisp-location-file (oref xref location)))) + + (setf (xref-elisp-location-file (oref expected-xref location)) + (downcase (xref-elisp-location-file (oref expected-xref location)))) + + (should (equal xref expected-xref)) + + (xref--goto-location (xref-item-location xref)) + (back-to-indentation) + (should (looking-at (or expected-source + (xref-elisp-test-descr-to-target expected))))) + )) + +(defmacro xref-elisp-deftest (name computed-xrefs expected-xrefs) + "Define an ert test for an xref-elisp feature. +COMPUTED-XREFS and EXPECTED-XREFS are lists of xrefs, except if +an element of EXPECTED-XREFS is a cons (XREF . TARGET), TARGET is +matched to the found location; otherwise, match +to (xref-elisp-test-descr-to-target xref)." + (declare (indent defun) + (debug (symbolp "name"))) + `(ert-deftest ,(intern (concat "xref-elisp-test-" (symbol-name name))) () + (let ((find-file-suppress-same-file-warnings t)) + (xref-elisp-test-run ,computed-xrefs ,expected-xrefs) + ))) + +;; When tests are run from the Makefile, 'default-directory' is $HOME, +;; so we must provide this dir to expand-file-name in the expected +;; results. This also allows running these tests from other +;; directories. +;; +;; We add 'downcase' here to deliberately cause a potential problem on +;; case-insensitive file systems. On such systems, `load-file-name' +;; may not have the same case as the real file system, since the user +;; can set `load-path' to have the wrong case (on my Windows system, +;; `load-path' has the correct case, so this causes the expected test +;; values to have the wrong case). This is handled in +;; `xref-elisp-test-run'. +(defconst emacs-test-dir (downcase (file-name-directory (or load-file-name (buffer-file-name))))) + + +;; alphabetical by test name + +;; Autoloads require no special support; they are handled as functions. + +;; FIXME: defalias-defun-c cmpl-prefix-entry-head +;; FIXME: defalias-defvar-el allout-mode-map + +(xref-elisp-deftest find-defs-constructor + (elisp--xref-find-definitions 'xref-make-elisp-location) + ;; 'xref-make-elisp-location' is just a name for the default + ;; constructor created by the cl-defstruct, so the location is the + ;; cl-defstruct location. + (list + (cons + (xref-make "(cl-defstruct (xref-elisp-location (:constructor xref-make-elisp-location)))" + (xref-make-elisp-location + 'xref-elisp-location 'define-type + (expand-file-name "../../../lisp/progmodes/elisp-mode.el" emacs-test-dir))) + ;; It's not worth adding another special case to `xref-elisp-test-descr-to-target' for this + "(cl-defstruct (xref-elisp-location") + )) + +(xref-elisp-deftest find-defs-defalias-defun-el + (elisp--xref-find-definitions 'Buffer-menu-sort) + (list + (xref-make "(defalias Buffer-menu-sort)" + (xref-make-elisp-location + 'Buffer-menu-sort 'defalias + (expand-file-name "../../../lisp/buff-menu.elc" emacs-test-dir))) + (xref-make "(defun tabulated-list-sort)" + (xref-make-elisp-location + 'tabulated-list-sort nil + (expand-file-name "../../../lisp/emacs-lisp/tabulated-list.el" emacs-test-dir))) + )) + +;; FIXME: defconst + +;; FIXME: eieio defclass + +;; Possible ways of defining the default method implementation for a +;; generic function. We declare these here, so we know we cover all +;; cases, and we don't rely on other code not changing. +;; +;; When the generic and default method are declared in the same place, +;; elisp--xref-find-definitions only returns one. + +(cl-defstruct (xref-elisp-root-type) + slot-1) + +(cl-defgeneric xref-elisp-generic-no-methods (arg1 arg2) + "doc string generic no-methods" + ;; No default implementation, no methods, but fboundp is true for + ;; this symbol; it calls cl-no-applicable-method + ) + +;; WORKAROUND: ‘this’ is unused, and the byte compiler complains, so +;; it should be spelled ‘_this’. But for some unknown reason, that +;; causes the batch mode test to fail; the symbol shows up as +;; ‘this’. It passes in interactive tests, so I haven't been able to +;; track down the problem. +(cl-defmethod xref-elisp-generic-no-default ((this xref-elisp-root-type) arg2) + "doc string generic no-default xref-elisp-root-type" + "non-default for no-default") + +;; defgeneric after defmethod in file to ensure the fallback search +;; method of just looking for the function name will fail. +(cl-defgeneric xref-elisp-generic-no-default (arg1 arg2) + "doc string generic no-default generic" + ;; No default implementation; this function calls the cl-generic + ;; dispatching code. + ) + +(cl-defgeneric xref-elisp-generic-co-located-default (arg1 arg2) + "doc string generic co-located-default" + "co-located default") + +(cl-defmethod xref-elisp-generic-co-located-default ((this xref-elisp-root-type) arg2) + "doc string generic co-located-default xref-elisp-root-type" + "non-default for co-located-default") + +(cl-defgeneric xref-elisp-generic-separate-default (arg1 arg2) + "doc string generic separate-default" + ;; default implementation provided separately + ) + +(cl-defmethod xref-elisp-generic-separate-default (arg1 arg2) + "doc string generic separate-default default" + "separate default") + +(cl-defmethod xref-elisp-generic-separate-default ((this xref-elisp-root-type) arg2) + "doc string generic separate-default xref-elisp-root-type" + "non-default for separate-default") + +(cl-defmethod xref-elisp-generic-implicit-generic (arg1 arg2) + "doc string generic implicit-generic default" + "default for implicit generic") + +(cl-defmethod xref-elisp-generic-implicit-generic ((this xref-elisp-root-type) arg2) + "doc string generic implicit-generic xref-elisp-root-type" + "non-default for implicit generic") + + +(xref-elisp-deftest find-defs-defgeneric-no-methods + (elisp--xref-find-definitions 'xref-elisp-generic-no-methods) + (list + (xref-make "(cl-defgeneric xref-elisp-generic-no-methods)" + (xref-make-elisp-location + 'xref-elisp-generic-no-methods 'cl-defgeneric + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defgeneric-no-default + (elisp--xref-find-definitions 'xref-elisp-generic-no-default) + (list + (xref-make "(cl-defgeneric xref-elisp-generic-no-default)" + (xref-make-elisp-location + 'xref-elisp-generic-no-default 'cl-defgeneric + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-elisp-generic-no-default ((this xref-elisp-root-type) arg2))" + (xref-make-elisp-location + (cl--generic-load-hist-format + 'xref-elisp-generic-no-default nil '(xref-elisp-root-type t)) + 'cl-defmethod + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defgeneric-co-located-default + (elisp--xref-find-definitions 'xref-elisp-generic-co-located-default) + (list + (xref-make "(cl-defgeneric xref-elisp-generic-co-located-default)" + (xref-make-elisp-location + 'xref-elisp-generic-co-located-default 'cl-defgeneric + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-elisp-generic-co-located-default ((this xref-elisp-root-type) arg2))" + (xref-make-elisp-location + (cl--generic-load-hist-format + 'xref-elisp-generic-co-located-default nil + '(xref-elisp-root-type t)) + 'cl-defmethod + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defgeneric-separate-default + (elisp--xref-find-definitions 'xref-elisp-generic-separate-default) + (list + (xref-make "(cl-defgeneric xref-elisp-generic-separate-default)" + (xref-make-elisp-location + 'xref-elisp-generic-separate-default 'cl-defgeneric + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-elisp-generic-separate-default (arg1 arg2))" + (xref-make-elisp-location + (cl--generic-load-hist-format + 'xref-elisp-generic-separate-default nil '(t t)) + 'cl-defmethod + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-elisp-generic-separate-default ((this xref-elisp-root-type) arg2))" + (xref-make-elisp-location + (cl--generic-load-hist-format + 'xref-elisp-generic-separate-default nil + '(xref-elisp-root-type t)) + 'cl-defmethod + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defgeneric-implicit-generic + (elisp--xref-find-definitions 'xref-elisp-generic-implicit-generic) + (list + (xref-make "(cl-defmethod xref-elisp-generic-implicit-generic (arg1 arg2))" + (xref-make-elisp-location + (cl--generic-load-hist-format + 'xref-elisp-generic-implicit-generic nil '(t t)) + 'cl-defmethod + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-elisp-generic-implicit-generic ((this xref-elisp-root-type) arg2))" + (xref-make-elisp-location + (cl--generic-load-hist-format + 'xref-elisp-generic-implicit-generic nil + '(xref-elisp-root-type t)) + 'cl-defmethod + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +;; Test that we handle more than one method + +;; When run from the Makefile, etags is not loaded at compile time, +;; but it is by the time this test is run. interactively; don't fail +;; for that. +(require 'etags) +(xref-elisp-deftest find-defs-defgeneric-el + (elisp--xref-find-definitions 'xref-location-marker) + (list + (xref-make "(cl-defgeneric xref-location-marker)" + (xref-make-elisp-location + 'xref-location-marker 'cl-defgeneric + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-location-marker ((l xref-elisp-location)))" + (xref-make-elisp-location + (cl--generic-load-hist-format + 'xref-location-marker nil '(xref-elisp-location)) + 'cl-defmethod + (expand-file-name "../../../lisp/progmodes/elisp-mode.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-location-marker ((l xref-file-location)))" + (xref-make-elisp-location + (cl--generic-load-hist-format + 'xref-location-marker nil '(xref-file-location)) + 'cl-defmethod + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-location-marker ((l xref-buffer-location)))" + (xref-make-elisp-location + (cl--generic-load-hist-format + 'xref-location-marker nil '(xref-buffer-location)) + 'cl-defmethod + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-location-marker ((l xref-bogus-location)))" + (xref-make-elisp-location + (cl--generic-load-hist-format + 'xref-location-marker nil '(xref-bogus-location)) + 'cl-defmethod + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-location-marker ((l xref-etags-location)))" + (xref-make-elisp-location + (cl--generic-load-hist-format + 'xref-location-marker nil '(xref-etags-location)) + 'cl-defmethod + (expand-file-name "../../../lisp/progmodes/etags.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defgeneric-eval + (elisp--xref-find-definitions (eval '(cl-defgeneric stephe-leake-cl-defgeneric ()))) + nil) + +;; Define some mode-local overloadable/overridden functions for xref to find +(require 'mode-local) + +(define-overloadable-function xref-elisp-overloadable-no-methods () + "doc string overloadable no-methods") + +(define-overloadable-function xref-elisp-overloadable-no-default () + "doc string overloadable no-default") + +;; FIXME: byte compiler complains about unused lexical arguments +;; generated by this macro. +(define-mode-local-override xref-elisp-overloadable-no-default c-mode + (start end &optional nonterminal depth returnonerror) + "doc string overloadable no-default c-mode." + "result overloadable no-default c-mode.") + +(define-overloadable-function xref-elisp-overloadable-co-located-default () + "doc string overloadable co-located-default" + "result overloadable co-located-default.") + +(define-mode-local-override xref-elisp-overloadable-co-located-default c-mode + (start end &optional nonterminal depth returnonerror) + "doc string overloadable co-located-default c-mode." + "result overloadable co-located-default c-mode.") + +(define-overloadable-function xref-elisp-overloadable-separate-default () + "doc string overloadable separate-default.") + +(defun xref-elisp-overloadable-separate-default-default () + "doc string overloadable separate-default default" + "result overloadable separate-default.") + +(define-mode-local-override xref-elisp-overloadable-separate-default c-mode + (start end &optional nonterminal depth returnonerror) + "doc string overloadable separate-default c-mode." + "result overloadable separate-default c-mode.") + +(xref-elisp-deftest find-defs-define-overload-no-methods + (elisp--xref-find-definitions 'xref-elisp-overloadable-no-methods) + (list + (xref-make "(define-overloadable-function xref-elisp-overloadable-no-methods)" + (xref-make-elisp-location + 'xref-elisp-overloadable-no-methods 'define-overloadable-function + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-define-overload-no-default + (elisp--xref-find-definitions 'xref-elisp-overloadable-no-default) + (list + (xref-make "(define-overloadable-function xref-elisp-overloadable-no-default)" + (xref-make-elisp-location + 'xref-elisp-overloadable-no-default 'define-overloadable-function + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(define-mode-local-override xref-elisp-overloadable-no-default c-mode)" + (xref-make-elisp-location + '(xref-elisp-overloadable-no-default-c-mode . c-mode) 'define-mode-local-override + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-define-overload-co-located-default + (elisp--xref-find-definitions 'xref-elisp-overloadable-co-located-default) + (list + (xref-make "(define-overloadable-function xref-elisp-overloadable-co-located-default)" + (xref-make-elisp-location + 'xref-elisp-overloadable-co-located-default 'define-overloadable-function + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(define-mode-local-override xref-elisp-overloadable-co-located-default c-mode)" + (xref-make-elisp-location + '(xref-elisp-overloadable-co-located-default-c-mode . c-mode) 'define-mode-local-override + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-define-overload-separate-default + (elisp--xref-find-definitions 'xref-elisp-overloadable-separate-default) + (list + (xref-make "(define-overloadable-function xref-elisp-overloadable-separate-default)" + (xref-make-elisp-location + 'xref-elisp-overloadable-separate-default 'define-overloadable-function + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(defun xref-elisp-overloadable-separate-default-default)" + (xref-make-elisp-location + 'xref-elisp-overloadable-separate-default-default nil + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + (xref-make "(define-mode-local-override xref-elisp-overloadable-separate-default c-mode)" + (xref-make-elisp-location + '(xref-elisp-overloadable-separate-default-c-mode . c-mode) 'define-mode-local-override + (expand-file-name "elisp-mode-tests.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defun-el + (elisp--xref-find-definitions 'xref-find-definitions) + (list + (xref-make "(defun xref-find-definitions)" + (xref-make-elisp-location + 'xref-find-definitions nil + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))))) + +(xref-elisp-deftest find-defs-defun-eval + (elisp--xref-find-definitions (eval '(defun stephe-leake-defun ()))) + nil) + +(xref-elisp-deftest find-defs-defun-c + (elisp--xref-find-definitions 'buffer-live-p) + (list + (xref-make "(defun buffer-live-p)" + (xref-make-elisp-location 'buffer-live-p nil "src/buffer.c")))) + +;; FIXME: deftype + +(xref-elisp-deftest find-defs-defun-c-defvar-c + (xref-backend-definitions 'elisp "system-name") + (list + (xref-make "(defvar system-name)" + (xref-make-elisp-location 'system-name 'defvar "src/editfns.c")) + (xref-make "(defun system-name)" + (xref-make-elisp-location 'system-name nil "src/editfns.c"))) + ) + +(xref-elisp-deftest find-defs-defun-el-defvar-c + (xref-backend-definitions 'elisp "abbrev-mode") + ;; It's a minor mode, but the variable is defined in buffer.c + (list + (xref-make "(defvar abbrev-mode)" + (xref-make-elisp-location 'abbrev-mode 'defvar "src/buffer.c")) + (cons + (xref-make "(defun abbrev-mode)" + (xref-make-elisp-location + 'abbrev-mode nil + (expand-file-name "../../../lisp/abbrev.el" emacs-test-dir))) + "(define-minor-mode abbrev-mode")) + ) + +;; Source for both variable and defun is "(define-minor-mode +;; compilation-minor-mode". There is no way to tell that directly from +;; the symbol, but we can use (memq sym minor-mode-list) to detect +;; that the symbol is a minor mode. See `elisp--xref-find-definitions' +;; for more comments. +;; +;; IMPROVEME: return defvar instead of defun if source near starting +;; point indicates the user is searching for a variable, not a +;; function. +(require 'compile) ;; not loaded by default at test time +(xref-elisp-deftest find-defs-defun-defvar-el + (elisp--xref-find-definitions 'compilation-minor-mode) + (list + (cons + (xref-make "(defun compilation-minor-mode)" + (xref-make-elisp-location + 'compilation-minor-mode nil + (expand-file-name "../../../lisp/progmodes/compile.el" emacs-test-dir))) + "(define-minor-mode compilation-minor-mode") + )) + +(xref-elisp-deftest find-defs-defvar-el + (elisp--xref-find-definitions 'xref--marker-ring) + (list + (xref-make "(defvar xref--marker-ring)" + (xref-make-elisp-location + 'xref--marker-ring 'defvar + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-defvar-c + (elisp--xref-find-definitions 'default-directory) + (list + (cons + (xref-make "(defvar default-directory)" + (xref-make-elisp-location 'default-directory 'defvar "src/buffer.c")) + ;; IMPROVEME: we might be able to compute this target + "DEFVAR_PER_BUFFER (\"default-directory\""))) + +(xref-elisp-deftest find-defs-defvar-eval + (elisp--xref-find-definitions (eval '(defvar stephe-leake-defvar nil))) + nil) + +(xref-elisp-deftest find-defs-face-el + (elisp--xref-find-definitions 'font-lock-keyword-face) + ;; 'font-lock-keyword-face is both a face and a var + (list + (xref-make "(defvar font-lock-keyword-face)" + (xref-make-elisp-location + 'font-lock-keyword-face 'defvar + (expand-file-name "../../../lisp/font-lock.el" emacs-test-dir))) + (xref-make "(defface font-lock-keyword-face)" + (xref-make-elisp-location + 'font-lock-keyword-face 'defface + (expand-file-name "../../../lisp/font-lock.el" emacs-test-dir))) + )) + +(xref-elisp-deftest find-defs-face-eval + (elisp--xref-find-definitions (eval '(defface stephe-leake-defface nil ""))) + nil) + +(xref-elisp-deftest find-defs-feature-el + (elisp--xref-find-definitions 'xref) + (list + (cons + (xref-make "(feature xref)" + (xref-make-elisp-location + 'xref 'feature + (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) + ";;; Code:") + )) + +(xref-elisp-deftest find-defs-feature-eval + (elisp--xref-find-definitions (eval '(provide 'stephe-leake-feature))) + nil) + +(ert-deftest elisp--preceding-sexp--char-name () + (with-temp-buffer + (emacs-lisp-mode) + (insert "?\\N{HEAVY CHECK MARK}") + (should (equal (elisp--preceding-sexp) ?\N{HEAVY CHECK MARK})))) + +(provide 'elisp-mode-tests) +;;; elisp-mode-tests.el ends here diff --cc test/lisp/progmodes/f90.el index 29c608847f1,00000000000..cda39eda376 mode 100644,000000..100644 --- a/test/lisp/progmodes/f90.el +++ b/test/lisp/progmodes/f90.el @@@ -1,276 -1,0 +1,276 @@@ +;;; f90.el --- tests for progmodes/f90.el + - ;; Copyright (C) 2011-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2011-2017 Free Software Foundation, Inc. + +;; Author: Glenn Morris + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This file does not have "test" in the name, because it lives under +;; a test/ directory, so that would be superfluous. + +;;; Code: + +(require 'ert) +(require 'f90) + +(defconst f90-test-indent "\ +!! Comment before code. +!!! Comments before code. +#preprocessor before code + +program progname + + implicit none + + integer :: i + + !! Comment. + + do i = 1, 10 + +#preprocessor + + !! Comment. + if ( i % 2 == 0 ) then + !! Comment. + cycle + else + write(*,*) i + end if + end do + +!!! Comment. + +end program progname +" + "Test string for F90 indentation.") + +(ert-deftest f90-test-indent () + "Test F90 indentation." + (with-temp-buffer + (f90-mode) + (insert f90-test-indent) + (indent-rigidly (point-min) (point-max) -999) + (f90-indent-region (point-min) (point-max)) + (should (string-equal (buffer-string) f90-test-indent)))) + +(ert-deftest f90-test-bug3729 () + "Test for http://debbugs.gnu.org/3729 ." + :expected-result :failed + (with-temp-buffer + (f90-mode) + (insert "!! Comment + +include \"file.f90\" + +subroutine test (x) + real x + x = x+1. + return +end subroutine test") + (goto-char (point-min)) + (forward-line 2) + (f90-indent-subprogram) + (should (= 0 (current-indentation))))) + +(ert-deftest f90-test-bug3730 () + "Test for http://debbugs.gnu.org/3730 ." + (with-temp-buffer + (f90-mode) + (insert "a" ) + (move-to-column 68 t) + (insert "(/ x /)") + (f90-do-auto-fill) + (beginning-of-line) + (skip-chars-forward "[ \t]") + (should (equal "&(/" (buffer-substring (point) (+ 3 (point))))))) + +;; TODO bug#5593 + +(ert-deftest f90-test-bug8691 () + "Test for http://debbugs.gnu.org/8691 ." + (with-temp-buffer + (f90-mode) + (insert "module modname +type, bind(c) :: type1 +integer :: part1 +end type type1 +end module modname") + (f90-indent-subprogram) + (forward-line -1) + (should (= 2 (current-indentation))))) + +;; TODO bug#8812 + +(ert-deftest f90-test-bug8820 () + "Test for http://debbugs.gnu.org/8820 ." + (with-temp-buffer + (f90-mode) + (should (eq (char-syntax ?%) (string-to-char "."))))) + +(ert-deftest f90-test-bug9553a () + "Test for http://debbugs.gnu.org/9553 ." + (with-temp-buffer + (f90-mode) + (insert "!!!") + (dotimes (_i 20) (insert " aaaa")) + (f90-do-auto-fill) + (beginning-of-line) + ;; This gives a more informative failure than looking-at. + (should (equal "!!! a" (buffer-substring (point) (+ 5 (point))))))) + +(ert-deftest f90-test-bug9553b () + "Test for http://debbugs.gnu.org/9553 ." + (with-temp-buffer + (f90-mode) + (insert "!!!") + (dotimes (_i 13) (insert " aaaa")) + (insert "a, aaaa") + (f90-do-auto-fill) + (beginning-of-line) + (should (equal "!!! a" (buffer-substring (point) (+ 5 (point))))))) + +(ert-deftest f90-test-bug9690 () + "Test for http://debbugs.gnu.org/9690 ." + (with-temp-buffer + (f90-mode) + (insert "#include \"foo.h\"") + (f90-indent-line) + (should (= 0 (current-indentation))))) + +(ert-deftest f90-test-bug13138 () + "Test for http://debbugs.gnu.org/13138 ." + (with-temp-buffer + (f90-mode) + (insert "program prog + integer :: i = & +#ifdef foo + & 1 +#else + & 2 +#endif + + write(*,*) i +end program prog") + (goto-char (point-min)) + (forward-line 2) + (f90-indent-subprogram) + (should (= 0 (current-indentation))))) + +(ert-deftest f90-test-bug-19809 () + "Test for http://debbugs.gnu.org/19809 ." + (with-temp-buffer + (f90-mode) + ;; The Fortran standard says that continued strings should have + ;; '&' at the start of continuation lines, but it seems gfortran + ;; allows them to be absent (albeit with a warning). + (insert "program prog + write (*,*), '& +end program prog' +end program prog") + (goto-char (point-min)) + (f90-end-of-subprogram) + (should (= (point) (point-max))))) + +(ert-deftest f90-test-bug20680 () + "Test for http://debbugs.gnu.org/20680 ." + (with-temp-buffer + (f90-mode) + (insert "module modname +type, extends ( sometype ) :: type1 +integer :: part1 +end type type1 +end module modname") + (f90-indent-subprogram) + (forward-line -1) + (should (= 2 (current-indentation))))) + +(ert-deftest f90-test-bug20680b () + "Test for http://debbugs.gnu.org/20680 ." + (with-temp-buffer + (f90-mode) + (insert "module modname +enum, bind(c) +enumerator :: e1 = 0 +end enum +end module modname") + (f90-indent-subprogram) + (forward-line -1) + (should (= 2 (current-indentation))))) + +(ert-deftest f90-test-bug20969 () + "Test for http://debbugs.gnu.org/20969 ." + (with-temp-buffer + (f90-mode) + (insert "module modname +type, extends ( sometype ), private :: type1 +integer :: part1 +end type type1 +end module modname") + (f90-indent-subprogram) + (forward-line -1) + (should (= 2 (current-indentation))))) + +(ert-deftest f90-test-bug20969b () + "Test for http://debbugs.gnu.org/20969 ." + (with-temp-buffer + (f90-mode) + (insert "module modname +type, private, extends ( sometype ) :: type1 +integer :: part1 +end type type1 +end module modname") + (f90-indent-subprogram) + (forward-line -1) + (should (= 2 (current-indentation))))) + +(ert-deftest f90-test-bug21794 () + "Test for http://debbugs.gnu.org/21794 ." + (with-temp-buffer + (f90-mode) + (insert "program prog +do i=1,10 +associate (x => xa(i), y => ya(i)) +a(x,y,i) = fun(x,y,i) +end associate +end do +end program prog") + (f90-indent-subprogram) + (forward-line -2) + (should (= 5 (current-indentation))))) + +(ert-deftest f90-test-bug25039 () + "Test for http://debbugs.gnu.org/25039 ." + (with-temp-buffer + (f90-mode) + (insert "program prog +select type (a) +class is (c1) +x = 1 +type is (t1) +x = 2 +end select +end program prog") + (f90-indent-subprogram) + (forward-line -3) + (should (= 2 (current-indentation))) ; type is + (forward-line -2) + (should (= 2 (current-indentation))))) ; class is + +;;; f90.el ends here diff --cc test/lisp/progmodes/flymake-tests.el index 386516190bb,00000000000..9bf6e7aa178 mode 100644,000000..100644 --- a/test/lisp/progmodes/flymake-tests.el +++ b/test/lisp/progmodes/flymake-tests.el @@@ -1,80 -1,0 +1,80 @@@ +;;; flymake-tests.el --- Test suite for flymake + - ;; Copyright (C) 2011-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2011-2017 Free Software Foundation, Inc. + +;; Author: Eduard Wiebe + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: +(require 'ert) +(require 'flymake) + +(defvar flymake-tests-data-directory + (expand-file-name "lisp/progmodes/flymake-resources" (getenv "EMACS_TEST_DIRECTORY")) + "Directory containing flymake test data.") + + +;; Warning predicate +(defun flymake-tests--current-face (file predicate) + (let ((buffer (find-file-noselect + (expand-file-name file flymake-tests-data-directory))) + (process-environment (cons "LC_ALL=C" process-environment)) + (i 0)) + (unwind-protect + (with-current-buffer buffer + (setq-local flymake-warning-predicate predicate) + (goto-char (point-min)) + (flymake-mode 1) + ;; Weirdness here... http://debbugs.gnu.org/17647#25 + (while (and flymake-is-running (< (setq i (1+ i)) 10)) + (sleep-for (+ 0.5 flymake-no-changes-timeout))) + (flymake-goto-next-error) + (face-at-point)) + (and buffer (let (kill-buffer-query-functions) (kill-buffer buffer)))))) + +(ert-deftest warning-predicate-rx-gcc () + "Test GCC warning via regexp predicate." + (skip-unless (and (executable-find "gcc") (executable-find "make"))) + (should (eq 'flymake-warnline + (flymake-tests--current-face "test.c" "^[Ww]arning")))) + +(ert-deftest warning-predicate-function-gcc () + "Test GCC warning via function predicate." + (skip-unless (and (executable-find "gcc") (executable-find "make"))) + (should (eq 'flymake-warnline + (flymake-tests--current-face "test.c" + (lambda (msg) (string-match "^[Ww]arning" msg)))))) + +(ert-deftest warning-predicate-rx-perl () + "Test perl warning via regular expression predicate." + (skip-unless (executable-find "perl")) + (should (eq 'flymake-warnline + (flymake-tests--current-face "test.pl" "^Scalar value")))) + +(ert-deftest warning-predicate-function-perl () + "Test perl warning via function predicate." + (skip-unless (executable-find "perl")) + (should (eq 'flymake-warnline + (flymake-tests--current-face + "test.pl" + (lambda (msg) (string-match "^Scalar value" msg)))))) + +(provide 'flymake-tests) + +;;; flymake.el ends here diff --cc test/lisp/progmodes/python-tests.el index f6564dd58cc,00000000000..94c356b589e mode 100644,000000..100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@@ -1,5295 -1,0 +1,5295 @@@ +;;; python-tests.el --- Test suite for python.el + - ;; Copyright (C) 2013-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'python) + +;; Dependencies for testing: +(require 'electric) +(require 'hideshow) +(require 'tramp-sh) + + +(defmacro python-tests-with-temp-buffer (contents &rest body) + "Create a `python-mode' enabled temp buffer with CONTENTS. +BODY is code to be executed within the temp buffer. Point is +always located at the beginning of buffer." + (declare (indent 1) (debug t)) + `(with-temp-buffer + (let ((python-indent-guess-indent-offset nil)) + (python-mode) + (insert ,contents) + (goto-char (point-min)) + ,@body))) + +(defmacro python-tests-with-temp-file (contents &rest body) + "Create a `python-mode' enabled file with CONTENTS. +BODY is code to be executed within the temp buffer. Point is +always located at the beginning of buffer." + (declare (indent 1) (debug t)) + ;; temp-file never actually used for anything? + `(let* ((temp-file (make-temp-file "python-tests" nil ".py")) + (buffer (find-file-noselect temp-file)) + (python-indent-guess-indent-offset nil)) + (unwind-protect + (with-current-buffer buffer + (python-mode) + (insert ,contents) + (goto-char (point-min)) + ,@body) + (and buffer (kill-buffer buffer)) + (delete-file temp-file)))) + +(defun python-tests-look-at (string &optional num restore-point) + "Move point at beginning of STRING in the current buffer. +Optional argument NUM defaults to 1 and is an integer indicating +how many occurrences must be found, when positive the search is +done forwards, otherwise backwards. When RESTORE-POINT is +non-nil the point is not moved but the position found is still +returned. When searching forward and point is already looking at +STRING, it is skipped so the next STRING occurrence is selected." + (let* ((num (or num 1)) + (starting-point (point)) + (string (regexp-quote string)) + (search-fn (if (> num 0) #'re-search-forward #'re-search-backward)) + (deinc-fn (if (> num 0) #'1- #'1+)) + (found-point)) + (prog2 + (catch 'exit + (while (not (= num 0)) + (when (and (> num 0) + (looking-at string)) + ;; Moving forward and already looking at STRING, skip it. + (forward-char (length (match-string-no-properties 0)))) + (and (not (funcall search-fn string nil t)) + (throw 'exit t)) + (when (> num 0) + ;; `re-search-forward' leaves point at the end of the + ;; occurrence, move back so point is at the beginning + ;; instead. + (forward-char (- (length (match-string-no-properties 0))))) + (setq + num (funcall deinc-fn num) + found-point (point)))) + found-point + (and restore-point (goto-char starting-point))))) + +(defun python-tests-self-insert (char-or-str) + "Call `self-insert-command' for chars in CHAR-OR-STR." + (let ((chars + (cond + ((characterp char-or-str) + (list char-or-str)) + ((stringp char-or-str) + (string-to-list char-or-str)) + ((not + (cl-remove-if #'characterp char-or-str)) + char-or-str) + (t (error "CHAR-OR-STR must be a char, string, or list of char"))))) + (mapc + (lambda (char) + (let ((last-command-event char)) + (call-interactively 'self-insert-command))) + chars))) + +(defun python-tests-visible-string (&optional min max) + "Return the buffer string excluding invisible overlays. +Argument MIN and MAX delimit the region to be returned and +default to `point-min' and `point-max' respectively." + (let* ((min (or min (point-min))) + (max (or max (point-max))) + (buffer (current-buffer)) + (buffer-contents (buffer-substring-no-properties min max)) + (overlays + (sort (overlays-in min max) + (lambda (a b) + (let ((overlay-end-a (overlay-end a)) + (overlay-end-b (overlay-end b))) + (> overlay-end-a overlay-end-b)))))) + (with-temp-buffer + (insert buffer-contents) + (dolist (overlay overlays) + (if (overlay-get overlay 'invisible) + (delete-region (overlay-start overlay) + (overlay-end overlay)))) + (buffer-substring-no-properties (point-min) (point-max))))) + + +;;; Tests for your tests, so you can test while you test. + +(ert-deftest python-tests-look-at-1 () + "Test forward movement." + (python-tests-with-temp-buffer + "Lorem ipsum dolor sit amet, consectetur adipisicing elit, +sed do eiusmod tempor incididunt ut labore et dolore magna +aliqua." + (let ((expected (save-excursion + (dotimes (i 3) + (re-search-forward "et" nil t)) + (forward-char -2) + (point)))) + (should (= (python-tests-look-at "et" 3 t) expected)) + ;; Even if NUM is bigger than found occurrences the point of last + ;; one should be returned. + (should (= (python-tests-look-at "et" 6 t) expected)) + ;; If already looking at STRING, it should skip it. + (dotimes (i 2) (re-search-forward "et")) + (forward-char -2) + (should (= (python-tests-look-at "et") expected))))) + +(ert-deftest python-tests-look-at-2 () + "Test backward movement." + (python-tests-with-temp-buffer + "Lorem ipsum dolor sit amet, consectetur adipisicing elit, +sed do eiusmod tempor incididunt ut labore et dolore magna +aliqua." + (let ((expected + (save-excursion + (re-search-forward "et" nil t) + (forward-char -2) + (point)))) + (dotimes (i 3) + (re-search-forward "et" nil t)) + (should (= (python-tests-look-at "et" -3 t) expected)) + (should (= (python-tests-look-at "et" -6 t) expected))))) + + +;;; Bindings + + +;;; Python specialized rx + + +;;; Font-lock and syntax + +(ert-deftest python-syntax-after-python-backspace () + ;; `python-indent-dedent-line-backspace' garbles syntax + :expected-result :failed + (python-tests-with-temp-buffer + "\"\"\"" + (goto-char (point-max)) + (python-indent-dedent-line-backspace 1) + (should (string= (buffer-string) "\"\"")) + (should (null (nth 3 (syntax-ppss)))))) + + +;;; Indentation + +;; See: http://www.python.org/dev/peps/pep-0008/#indentation + +(ert-deftest python-indent-pep8-1 () + "First pep8 case." + (python-tests-with-temp-buffer + "# Aligned with opening delimiter +foo = long_function_name(var_one, var_two, + var_three, var_four) +" + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "foo = long_function_name(var_one, var_two,") + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "var_three, var_four)") + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 25)))) + +(ert-deftest python-indent-pep8-2 () + "Second pep8 case." + (python-tests-with-temp-buffer + "# More indentation included to distinguish this from the rest. +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "def long_function_name(") + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "var_one, var_two, var_three,") + (should (eq (car (python-indent-context)) + :inside-paren-newline-start-from-block)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "var_four):") + (should (eq (car (python-indent-context)) + :inside-paren-newline-start-from-block)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "print (var_one)") + (should (eq (car (python-indent-context)) + :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-pep8-3 () + "Third pep8 case." + (python-tests-with-temp-buffer + "# Extra indentation is not necessary. +foo = long_function_name( + var_one, var_two, + var_three, var_four) +" + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "foo = long_function_name(") + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "var_one, var_two,") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "var_three, var_four)") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-base-case () + "Check base case does not trigger errors." + (python-tests-with-temp-buffer + " + +" + (goto-char (point-min)) + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-after-comment-1 () + "The most simple after-comment case that shouldn't fail." + (python-tests-with-temp-buffer + "# Contents will be modified to correct indentation +class Blag(object): + def _on_child_complete(self, child_future): + if self.in_terminal_state(): + pass + # We only complete when all our async children have entered a + # terminal state. At that point, if any child failed, we fail +# with the exception with which the first child failed. +" + (python-tests-look-at "# We only complete") + (should (eq (car (python-indent-context)) :after-block-end)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "# terminal state") + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "# with the exception") + (should (eq (car (python-indent-context)) :after-comment)) + ;; This one indents relative to previous block, even given the fact + ;; that it was under-indented. + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "# terminal state" -1) + ;; It doesn't hurt to check again. + (should (eq (car (python-indent-context)) :after-comment)) + (python-indent-line) + (should (= (current-indentation) 8)) + (python-tests-look-at "# with the exception") + (should (eq (car (python-indent-context)) :after-comment)) + ;; Now everything should be lined up. + (should (= (python-indent-calculate-indentation) 8)))) + +(ert-deftest python-indent-after-comment-2 () + "Test after-comment in weird cases." + (python-tests-with-temp-buffer + "# Contents will be modified to correct indentation +def func(arg): + # I don't do much + return arg + # This comment is badly indented because the user forced so. + # At this line python.el wont dedent, user is always right. + +comment_wins_over_ender = True + +# yeah, that. +" + (python-tests-look-at "# I don't do much") + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "return arg") + ;; Comment here just gets ignored, this line is not a comment so + ;; the rules won't apply here. + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "# This comment is badly indented") + (should (eq (car (python-indent-context)) :after-block-end)) + ;; The return keyword do make indentation lose a level... + (should (= (python-indent-calculate-indentation) 0)) + ;; ...but the current indentation was forced by the user. + (python-tests-look-at "# At this line python.el wont dedent") + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 4)) + ;; Should behave the same for blank lines: potentially a comment. + (forward-line 1) + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "comment_wins_over_ender") + ;; The comment won over the ender because the user said so. + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 4)) + ;; The indentation calculated fine for the assignment, but the user + ;; choose to force it back to the first column. Next line should + ;; be aware of that. + (python-tests-look-at "# yeah, that.") + (should (eq (car (python-indent-context)) :after-line)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-after-comment-3 () + "Test after-comment in buggy case." + (python-tests-with-temp-buffer + " +class A(object): + + def something(self, arg): + if True: + return arg + + # A comment + + @adecorator + def method(self, a, b): + pass +" + (python-tests-look-at "@adecorator") + (should (eq (car (python-indent-context)) :after-comment)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-inside-paren-1 () + "The most simple inside-paren case that shouldn't fail." + (python-tests-with-temp-buffer + " +data = { + 'key': + { + 'objlist': [ + { + 'pk': 1, + 'name': 'first', + }, + { + 'pk': 2, + 'name': 'second', + } + ] + } +} +" + (python-tests-look-at "data = {") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "'key':") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "{") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "'objlist': [") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "{") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 12)) + (python-tests-look-at "'pk': 1,") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 16)) + (python-tests-look-at "'name': 'first',") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 16)) + (python-tests-look-at "},") + (should (eq (car (python-indent-context)) + :inside-paren-at-closing-nested-paren)) + (should (= (python-indent-calculate-indentation) 12)) + (python-tests-look-at "{") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 12)) + (python-tests-look-at "'pk': 2,") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 16)) + (python-tests-look-at "'name': 'second',") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 16)) + (python-tests-look-at "}") + (should (eq (car (python-indent-context)) + :inside-paren-at-closing-nested-paren)) + (should (= (python-indent-calculate-indentation) 12)) + (python-tests-look-at "]") + (should (eq (car (python-indent-context)) + :inside-paren-at-closing-nested-paren)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "}") + (should (eq (car (python-indent-context)) + :inside-paren-at-closing-nested-paren)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "}") + (should (eq (car (python-indent-context)) :inside-paren-at-closing-paren)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-inside-paren-2 () + "Another more compact paren group style." + (python-tests-with-temp-buffer + " +data = {'key': { + 'objlist': [ + {'pk': 1, + 'name': 'first'}, + {'pk': 2, + 'name': 'second'} + ] +}} +" + (python-tests-look-at "data = {") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "'objlist': [") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "{'pk': 1,") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "'name': 'first'},") + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 9)) + (python-tests-look-at "{'pk': 2,") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "'name': 'second'}") + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 9)) + (python-tests-look-at "]") + (should (eq (car (python-indent-context)) + :inside-paren-at-closing-nested-paren)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "}}") + (should (eq (car (python-indent-context)) + :inside-paren-at-closing-nested-paren)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "}") + (should (eq (car (python-indent-context)) :inside-paren-at-closing-paren)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-inside-paren-3 () + "The simplest case possible." + (python-tests-with-temp-buffer + " +data = ('these', + 'are', + 'the', + 'tokens') +" + (python-tests-look-at "data = ('these',") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 8)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 8)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 8)))) + +(ert-deftest python-indent-inside-paren-4 () + "Respect indentation of first column." + (python-tests-with-temp-buffer + " +data = [ [ 'these', 'are'], + ['the', 'tokens' ] ] +" + (python-tests-look-at "data = [ [ 'these', 'are'],") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 9)))) + +(ert-deftest python-indent-inside-paren-5 () + "Test when :inside-paren initial parens are skipped in context start." + (python-tests-with-temp-buffer + " +while ((not some_condition) and + another_condition): + do_something_interesting( + with_some_arg) +" + (python-tests-look-at "while ((not some_condition) and") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 7)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 8)))) + +(ert-deftest python-indent-inside-paren-6 () + "This should be aligned.." + (python-tests-with-temp-buffer + " +CHOICES = (('some', 'choice'), + ('another', 'choice'), + ('more', 'choices')) +" + (python-tests-look-at "CHOICES = (('some', 'choice'),") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 11)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 11)))) + +(ert-deftest python-indent-inside-paren-7 () + "Test for Bug#21762." + (python-tests-with-temp-buffer + "import re as myre\nvar = [\n" + (goto-char (point-max)) + ;; This signals an error if the test fails + (should (eq (car (python-indent-context)) :inside-paren-newline-start)))) + +(ert-deftest python-indent-after-block-1 () + "The most simple after-block case that shouldn't fail." + (python-tests-with-temp-buffer + " +def foo(a, b, c=True): +" + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (goto-char (point-max)) + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-after-block-2 () + "A weird (malformed) multiline block statement." + (python-tests-with-temp-buffer + " +def foo(a, b, c={ + 'a': +}): +" + (goto-char (point-max)) + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-after-block-3 () + "A weird (malformed) sample, usually found in python shells." + (python-tests-with-temp-buffer + " +In [1]: +def func(): +pass + +In [2]: +something +" + (python-tests-look-at "pass") + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "something") + (end-of-line) + (should (eq (car (python-indent-context)) :after-line)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-after-async-block-1 () + "Test PEP492 async def." + (python-tests-with-temp-buffer + " +async def foo(a, b, c=True): +" + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (goto-char (point-max)) + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-after-async-block-2 () + "Test PEP492 async with." + (python-tests-with-temp-buffer + " +async with foo(a) as mgr: +" + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (goto-char (point-max)) + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-after-async-block-3 () + "Test PEP492 async for." + (python-tests-with-temp-buffer + " +async for a in sequencer(): +" + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (goto-char (point-max)) + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-after-backslash-1 () + "The most common case." + (python-tests-with-temp-buffer + " +from foo.bar.baz import something, something_1 \\\\ + something_2 something_3, \\\\ + something_4, something_5 +" + (python-tests-look-at "from foo.bar.baz import something, something_1") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "something_2 something_3,") + (should (eq (car (python-indent-context)) :after-backslash-first-line)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "something_4, something_5") + (should (eq (car (python-indent-context)) :after-backslash)) + (should (= (python-indent-calculate-indentation) 4)) + (goto-char (point-max)) + (should (eq (car (python-indent-context)) :after-line)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-after-backslash-2 () + "A pretty extreme complicated case." + (python-tests-with-temp-buffer + " +objects = Thing.objects.all() \\\\ + .filter( + type='toy', + status='bought' + ) \\\\ + .aggregate( + Sum('amount') + ) \\\\ + .values_list() +" + (python-tests-look-at "objects = Thing.objects.all()") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at ".filter(") + (should (eq (car (python-indent-context)) + :after-backslash-dotted-continuation)) + (should (= (python-indent-calculate-indentation) 23)) + (python-tests-look-at "type='toy',") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 27)) + (python-tests-look-at "status='bought'") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 27)) + (python-tests-look-at ") \\\\") + (should (eq (car (python-indent-context)) :inside-paren-at-closing-paren)) + (should (= (python-indent-calculate-indentation) 23)) + (python-tests-look-at ".aggregate(") + (should (eq (car (python-indent-context)) + :after-backslash-dotted-continuation)) + (should (= (python-indent-calculate-indentation) 23)) + (python-tests-look-at "Sum('amount')") + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 27)) + (python-tests-look-at ") \\\\") + (should (eq (car (python-indent-context)) :inside-paren-at-closing-paren)) + (should (= (python-indent-calculate-indentation) 23)) + (python-tests-look-at ".values_list()") + (should (eq (car (python-indent-context)) + :after-backslash-dotted-continuation)) + (should (= (python-indent-calculate-indentation) 23)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-line)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-after-backslash-3 () + "Backslash continuation from block start." + (python-tests-with-temp-buffer + " +with open('/path/to/some/file/you/want/to/read') as file_1, \\\\ + open('/path/to/some/file/being/written', 'w') as file_2: + file_2.write(file_1.read()) +" + (python-tests-look-at + "with open('/path/to/some/file/you/want/to/read') as file_1, \\\\") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at + "open('/path/to/some/file/being/written', 'w') as file_2") + (should (eq (car (python-indent-context)) + :after-backslash-block-continuation)) + (should (= (python-indent-calculate-indentation) 5)) + (python-tests-look-at "file_2.write(file_1.read())") + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-after-backslash-4 () + "Backslash continuation from assignment." + (python-tests-with-temp-buffer + " +super_awful_assignment = some_calculation() and \\\\ + another_calculation() and \\\\ + some_final_calculation() +" + (python-tests-look-at + "super_awful_assignment = some_calculation() and \\\\") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "another_calculation() and \\\\") + (should (eq (car (python-indent-context)) + :after-backslash-assignment-continuation)) + (should (= (python-indent-calculate-indentation) 25)) + (python-tests-look-at "some_final_calculation()") + (should (eq (car (python-indent-context)) :after-backslash)) + (should (= (python-indent-calculate-indentation) 25)))) + +(ert-deftest python-indent-after-backslash-5 () + "Dotted continuation bizarre example." + (python-tests-with-temp-buffer + " +def delete_all_things(): + Thing \\\\ + .objects.all() \\\\ + .delete() +" + (python-tests-look-at "Thing \\\\") + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at ".objects.all() \\\\") + (should (eq (car (python-indent-context)) :after-backslash-first-line)) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at ".delete()") + (should (eq (car (python-indent-context)) + :after-backslash-dotted-continuation)) + (should (= (python-indent-calculate-indentation) 16)))) + +(ert-deftest python-indent-block-enders-1 () + "Test de-indentation for pass keyword." + (python-tests-with-temp-buffer + " +Class foo(object): + + def bar(self): + if self.baz: + return (1, + 2, + 3) + + else: + pass +" + (python-tests-look-at "3)") + (forward-line 1) + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "pass") + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-end)) + (should (= (python-indent-calculate-indentation) 8)))) + +(ert-deftest python-indent-block-enders-2 () + "Test de-indentation for return keyword." + (python-tests-with-temp-buffer + " +Class foo(object): + '''raise lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do + + eiusmod tempor incididunt ut labore et dolore magna aliqua. + ''' + def bar(self): + \"return (1, 2, 3).\" + if self.baz: + return (1, + 2, + 3) +" + (python-tests-look-at "def") + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "if") + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "return") + (should (= (python-indent-calculate-indentation) 12)) + (goto-char (point-max)) + (should (eq (car (python-indent-context)) :after-block-end)) + (should (= (python-indent-calculate-indentation) 8)))) + +(ert-deftest python-indent-block-enders-3 () + "Test de-indentation for continue keyword." + (python-tests-with-temp-buffer + " +for element in lst: + if element is None: + continue +" + (python-tests-look-at "if") + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "continue") + (should (= (python-indent-calculate-indentation) 8)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-end)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-block-enders-4 () + "Test de-indentation for break keyword." + (python-tests-with-temp-buffer + " +for element in lst: + if element is None: + break +" + (python-tests-look-at "if") + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "break") + (should (= (python-indent-calculate-indentation) 8)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-end)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-block-enders-5 () + "Test de-indentation for raise keyword." + (python-tests-with-temp-buffer + " +for element in lst: + if element is None: + raise ValueError('Element cannot be None') +" + (python-tests-look-at "if") + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "raise") + (should (= (python-indent-calculate-indentation) 8)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-end)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-dedenters-1 () + "Test de-indentation for the elif keyword." + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + finally: + cleanup() + elif +" + (python-tests-look-at "elif\n") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 0)) + (should (= (python-indent-calculate-indentation t) 0)))) + +(ert-deftest python-indent-dedenters-2 () + "Test de-indentation for the else keyword." + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + except IOError: + msg = 'Error saving to disk' + message(msg) + logger.exception(msg) + except Exception: + if hide_details: + logger.exception('Unhandled exception') + else + finally: + data.free() +" + (python-tests-look-at "else\n") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 8)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 4)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 0)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 8)))) + +(ert-deftest python-indent-dedenters-3 () + "Test de-indentation for the except keyword." + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + except +" + (python-tests-look-at "except\n") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 4)))) + +(ert-deftest python-indent-dedenters-4 () + "Test de-indentation for the finally keyword." + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + finally +" + (python-tests-look-at "finally\n") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-dedenters-5 () + "Test invalid levels are skipped in a complex example." + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + except IOError: + msg = 'Error saving to disk' + message(msg) + logger.exception(msg) + finally: + if cleanup: + do_cleanup() + else +" + (python-tests-look-at "else\n") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 8)) + (should (= (python-indent-calculate-indentation t) 0)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 8)))) + +(ert-deftest python-indent-dedenters-6 () + "Test indentation is zero when no opening block for dedenter." + (python-tests-with-temp-buffer + " +try: + # if save: + write_to_disk(data) + else +" + (python-tests-look-at "else\n") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 0)) + (should (= (python-indent-calculate-indentation t) 0)))) + +(ert-deftest python-indent-dedenters-7 () + "Test indentation case from Bug#15163." + (python-tests-with-temp-buffer + " +if a: + if b: + pass + else: + pass + else: +" + (python-tests-look-at "else:" 2) + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 0)) + (should (= (python-indent-calculate-indentation t) 0)))) + +(ert-deftest python-indent-dedenters-8 () + "Test indentation for Bug#18432." + (python-tests-with-temp-buffer + " +if (a == 1 or + a == 2): + pass +elif (a == 3 or +a == 4): +" + (python-tests-look-at "elif (a == 3 or") + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 0)) + (should (= (python-indent-calculate-indentation t) 0)) + (python-tests-look-at "a == 4):\n") + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 6)) + (python-indent-line) + (should (= (python-indent-calculate-indentation t) 4)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 0)) + (python-indent-line t) + (should (= (python-indent-calculate-indentation t) 6)))) + +(ert-deftest python-indent-inside-string-1 () + "Test indentation for strings." + (python-tests-with-temp-buffer + " +multiline = ''' +bunch +of +lines +''' +" + (python-tests-look-at "multiline = '''") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "bunch") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "of") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "lines") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 0)) + (python-tests-look-at "'''") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 0)))) + +(ert-deftest python-indent-inside-string-2 () + "Test indentation for docstrings." + (python-tests-with-temp-buffer + " +def fn(a, b, c=True): + '''docstring + bunch + of + lines + ''' +" + (python-tests-look-at "'''docstring") + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "bunch") + (should (eq (car (python-indent-context)) :inside-docstring)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "of") + (should (eq (car (python-indent-context)) :inside-docstring)) + ;; Any indentation deeper than the base-indent must remain unmodified. + (should (= (python-indent-calculate-indentation) 8)) + (python-tests-look-at "lines") + (should (eq (car (python-indent-context)) :inside-docstring)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "'''") + (should (eq (car (python-indent-context)) :inside-docstring)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-inside-string-3 () + "Test indentation for nested strings." + (python-tests-with-temp-buffer + " +def fn(a, b, c=True): + some_var = ''' + bunch + of + lines + ''' +" + (python-tests-look-at "some_var = '''") + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "bunch") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "of") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "lines") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 4)) + (python-tests-look-at "'''") + (should (eq (car (python-indent-context)) :inside-string)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-electric-colon-1 () + "Test indentation case from Bug#18228." + (python-tests-with-temp-buffer + " +def a(): + pass + +def b() +" + (python-tests-look-at "def b()") + (goto-char (line-end-position)) + (python-tests-self-insert ":") + (should (= (current-indentation) 0)))) + +(ert-deftest python-indent-electric-colon-2 () + "Test indentation case for dedenter." + (python-tests-with-temp-buffer + " +if do: + something() + else +" + (python-tests-look-at "else") + (goto-char (line-end-position)) + (python-tests-self-insert ":") + (should (= (current-indentation) 0)))) + +(ert-deftest python-indent-electric-colon-3 () + "Test indentation case for multi-line dedenter." + (python-tests-with-temp-buffer + " +if do: + something() + elif (this + and + that) +" + (python-tests-look-at "that)") + (goto-char (line-end-position)) + (python-tests-self-insert ":") + (python-tests-look-at "elif" -1) + (should (= (current-indentation) 0)) + (python-tests-look-at "and") + (should (= (current-indentation) 6)) + (python-tests-look-at "that)") + (should (= (current-indentation) 6)))) + +(ert-deftest python-indent-region-1 () + "Test indentation case from Bug#18843." + (let ((contents " +def foo (): + try: + pass + except: + pass +")) + (python-tests-with-temp-buffer + contents + (python-indent-region (point-min) (point-max)) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + contents))))) + +(ert-deftest python-indent-region-2 () + "Test region indentation on comments." + (let ((contents " +def f(): + if True: + pass + +# This is +# some multiline +# comment +")) + (python-tests-with-temp-buffer + contents + (python-indent-region (point-min) (point-max)) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + contents))))) + +(ert-deftest python-indent-region-3 () + "Test region indentation on comments." + (let ((contents " +def f(): + if True: + pass +# This is +# some multiline +# comment +") + (expected " +def f(): + if True: + pass + # This is + # some multiline + # comment +")) + (python-tests-with-temp-buffer + contents + (python-indent-region (point-min) (point-max)) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + expected))))) + +(ert-deftest python-indent-region-4 () + "Test region indentation block starts, dedenters and enders." + (let ((contents " +def f(): + if True: +a = 5 + else: + a = 10 + return a +") + (expected " +def f(): + if True: + a = 5 + else: + a = 10 + return a +")) + (python-tests-with-temp-buffer + contents + (python-indent-region (point-min) (point-max)) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + expected))))) + +(ert-deftest python-indent-region-5 () + "Test region indentation for docstrings." + (let ((contents " +def f(): +''' +this is + a multiline +string +''' + x = \\ + ''' +this is an arbitrarily + indented multiline + string +''' +") + (expected " +def f(): + ''' + this is + a multiline + string + ''' + x = \\ + ''' +this is an arbitrarily + indented multiline + string +''' +")) + (python-tests-with-temp-buffer + contents + (python-indent-region (point-min) (point-max)) + (should (string= (buffer-substring-no-properties (point-min) (point-max)) + expected))))) + + +;;; Mark + +(ert-deftest python-mark-defun-1 () + """Test `python-mark-defun' with point at defun symbol start.""" + (python-tests-with-temp-buffer + " +def foo(x): + return x + +class A: + pass + +class B: + + def __init__(self): + self.b = 'b' + + def fun(self): + return self.b + +class C: + '''docstring''' +" + (let ((expected-mark-beginning-position + (progn + (python-tests-look-at "class A:") + (1- (point)))) + (expected-mark-end-position-1 + (save-excursion + (python-tests-look-at "pass") + (forward-line) + (point))) + (expected-mark-end-position-2 + (save-excursion + (python-tests-look-at "return self.b") + (forward-line) + (point))) + (expected-mark-end-position-3 + (save-excursion + (python-tests-look-at "'''docstring'''") + (forward-line) + (point)))) + ;; Select class A only, with point at bol. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position-1)) + ;; expand to class B, start position should remain the same. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position-2)) + ;; expand to class C, start position should remain the same. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position-3))))) + +(ert-deftest python-mark-defun-2 () + """Test `python-mark-defun' with point at nested defun symbol start.""" + (python-tests-with-temp-buffer + " +def foo(x): + return x + +class A: + pass + +class B: + + def __init__(self): + self.b = 'b' + + def fun(self): + return self.b + +class C: + '''docstring''' +" + (let ((expected-mark-beginning-position + (progn + (python-tests-look-at "def __init__(self):") + (1- (line-beginning-position)))) + (expected-mark-end-position-1 + (save-excursion + (python-tests-look-at "self.b = 'b'") + (forward-line) + (point))) + (expected-mark-end-position-2 + (save-excursion + (python-tests-look-at "return self.b") + (forward-line) + (point))) + (expected-mark-end-position-3 + (save-excursion + (python-tests-look-at "'''docstring'''") + (forward-line) + (point)))) + ;; Select B.__init only, with point at its start. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position-1)) + ;; expand to B.fun, start position should remain the same. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position-2)) + ;; expand to class C, start position should remain the same. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position-3))))) + +(ert-deftest python-mark-defun-3 () + """Test `python-mark-defun' with point inside defun symbol.""" + (python-tests-with-temp-buffer + " +def foo(x): + return x + +class A: + pass + +class B: + + def __init__(self): + self.b = 'b' + + def fun(self): + return self.b + +class C: + '''docstring''' +" + (let ((expected-mark-beginning-position + (progn + (python-tests-look-at "def fun(self):") + (python-tests-look-at "(self):") + (1- (line-beginning-position)))) + (expected-mark-end-position + (save-excursion + (python-tests-look-at "return self.b") + (forward-line) + (point)))) + ;; Should select B.fun, despite point is inside the defun symbol. + (python-mark-defun 1) + (should (= (point) expected-mark-beginning-position)) + (should (= (marker-position (mark-marker)) + expected-mark-end-position))))) + + +;;; Navigation + +(ert-deftest python-nav-beginning-of-defun-1 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (python-tests-look-at "return wrap") + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def wrapped_f(*args):" -1) + (beginning-of-line) + (point)))) + (python-tests-look-at "def wrapped_f(*args):" -1) + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def wwrap(f):" -1) + (beginning-of-line) + (point)))) + (python-tests-look-at "def wwrap(f):" -1) + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def decoratorFunctionWithArguments" -1) + (beginning-of-line) + (point)))))) + +(ert-deftest python-nav-beginning-of-defun-2 () + (python-tests-with-temp-buffer + " +class C(object): + + def m(self): + self.c() + + def b(): + pass + + def a(): + pass + + def c(self): + pass +" + ;; Nested defuns, are handled with care. + (python-tests-look-at "def c(self):") + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def m(self):" -1) + (beginning-of-line) + (point)))) + ;; Defuns on same levels should be respected. + (python-tests-look-at "def a():" -1) + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def b():" -1) + (beginning-of-line) + (point)))) + ;; Jump to a top level defun. + (python-tests-look-at "def b():" -1) + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def m(self):" -1) + (beginning-of-line) + (point)))) + ;; Jump to a top level defun again. + (python-tests-look-at "def m(self):" -1) + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "class C(object):" -1) + (beginning-of-line) + (point)))))) + +(ert-deftest python-nav-beginning-of-defun-3 () + (python-tests-with-temp-buffer + " +class C(object): + + async def m(self): + return await self.c() + + async def c(self): + pass +" + (python-tests-look-at "self.c()") + (should (= (save-excursion + (python-nav-beginning-of-defun) + (point)) + (save-excursion + (python-tests-look-at "async def m" -1) + (beginning-of-line) + (point)))))) + +(ert-deftest python-nav-end-of-defun-1 () + (python-tests-with-temp-buffer + " +class C(object): + + def m(self): + self.c() + + def b(): + pass + + def a(): + pass + + def c(self): + pass +" + (should (= (save-excursion + (python-tests-look-at "class C(object):") + (python-nav-end-of-defun) + (point)) + (save-excursion + (point-max)))) + (should (= (save-excursion + (python-tests-look-at "def m(self):") + (python-nav-end-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def c(self):") + (forward-line -1) + (point)))) + (should (= (save-excursion + (python-tests-look-at "def b():") + (python-nav-end-of-defun) + (point)) + (save-excursion + (python-tests-look-at "def b():") + (forward-line 2) + (point)))) + (should (= (save-excursion + (python-tests-look-at "def c(self):") + (python-nav-end-of-defun) + (point)) + (save-excursion + (point-max)))))) + +(ert-deftest python-nav-end-of-defun-2 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (should (= (save-excursion + (python-tests-look-at "def decoratorFunctionWithArguments") + (python-nav-end-of-defun) + (point)) + (save-excursion + (point-max)))) + (should (= (save-excursion + (python-tests-look-at "@decoratorFunctionWithArguments") + (python-nav-end-of-defun) + (point)) + (save-excursion + (point-max)))) + (should (= (save-excursion + (python-tests-look-at "def wwrap(f):") + (python-nav-end-of-defun) + (point)) + (save-excursion + (python-tests-look-at "return wwrap") + (line-beginning-position)))) + (should (= (save-excursion + (python-tests-look-at "def wrapped_f(*args):") + (python-nav-end-of-defun) + (point)) + (save-excursion + (python-tests-look-at "return wrapped_f") + (line-beginning-position)))) + (should (= (save-excursion + (python-tests-look-at "f(*args)") + (python-nav-end-of-defun) + (point)) + (save-excursion + (python-tests-look-at "return wrapped_f") + (line-beginning-position)))))) + +(ert-deftest python-nav-backward-defun-1 () + (python-tests-with-temp-buffer + " +class A(object): # A + + def a(self): # a + pass + + def b(self): # b + pass + + class B(object): # B + + class C(object): # C + + def d(self): # d + pass + + # def e(self): # e + # pass + + def c(self): # c + pass + + # def d(self): # d + # pass +" + (goto-char (point-max)) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " def c(self): # c" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " def d(self): # d" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " class C(object): # C" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " class B(object): # B" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " def b(self): # b" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " def a(self): # a" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at "class A(object): # A" -1))) + (should (not (python-nav-backward-defun))))) + +(ert-deftest python-nav-backward-defun-2 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (goto-char (point-max)) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " def wrapped_f(*args):" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at " def wwrap(f):" -1))) + (should (= (save-excursion (python-nav-backward-defun)) + (python-tests-look-at "def decoratorFunctionWithArguments(arg1, arg2, arg3):" -1))) + (should (not (python-nav-backward-defun))))) + +(ert-deftest python-nav-backward-defun-3 () + (python-tests-with-temp-buffer + " +''' + def u(self): + pass + + def v(self): + pass + + def w(self): + pass +''' + +class A(object): + pass +" + (goto-char (point-min)) + (let ((point (python-tests-look-at "class A(object):"))) + (should (not (python-nav-backward-defun))) + (should (= point (point)))))) + +(ert-deftest python-nav-forward-defun-1 () + (python-tests-with-temp-buffer + " +class A(object): # A + + def a(self): # a + pass + + def b(self): # b + pass + + class B(object): # B + + class C(object): # C + + def d(self): # d + pass + + # def e(self): # e + # pass + + def c(self): # c + pass + + # def d(self): # d + # pass +" + (goto-char (point-min)) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(object): # A"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(self): # a"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(self): # b"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(object): # B"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(object): # C"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(self): # d"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(self): # c"))) + (should (not (python-nav-forward-defun))))) + +(ert-deftest python-nav-forward-defun-2 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (goto-char (point-min)) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(arg1, arg2, arg3):"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(f):"))) + (should (= (save-excursion (python-nav-forward-defun)) + (python-tests-look-at "(*args):"))) + (should (not (python-nav-forward-defun))))) + +(ert-deftest python-nav-forward-defun-3 () + (python-tests-with-temp-buffer + " +class A(object): + pass + +''' + def u(self): + pass + + def v(self): + pass + + def w(self): + pass +''' +" + (goto-char (point-min)) + (let ((point (python-tests-look-at "(object):"))) + (should (not (python-nav-forward-defun))) + (should (= point (point)))))) + +(ert-deftest python-nav-beginning-of-statement-1 () + (python-tests-with-temp-buffer + " +v1 = 123 + \ + 456 + \ + 789 +v2 = (value1, + value2, + + value3, + value4) +v3 = ('this is a string' + + 'that is continued' + 'between lines' + 'within a paren', + # this is a comment, yo + 'continue previous line') +v4 = ''' +a very long +string +''' +" + (python-tests-look-at "v2 =") + (python-util-forward-comment -1) + (should (= (save-excursion + (python-nav-beginning-of-statement) + (point)) + (python-tests-look-at "v1 =" -1 t))) + (python-tests-look-at "v3 =") + (python-util-forward-comment -1) + (should (= (save-excursion + (python-nav-beginning-of-statement) + (point)) + (python-tests-look-at "v2 =" -1 t))) + (python-tests-look-at "v4 =") + (python-util-forward-comment -1) + (should (= (save-excursion + (python-nav-beginning-of-statement) + (point)) + (python-tests-look-at "v3 =" -1 t))) + (goto-char (point-max)) + (python-util-forward-comment -1) + (should (= (save-excursion + (python-nav-beginning-of-statement) + (point)) + (python-tests-look-at "v4 =" -1 t))))) + +(ert-deftest python-nav-end-of-statement-1 () + (python-tests-with-temp-buffer + " +v1 = 123 + \ + 456 + \ + 789 +v2 = (value1, + value2, + + value3, + value4) +v3 = ('this is a string' + + 'that is continued' + 'between lines' + 'within a paren', + # this is a comment, yo + 'continue previous line') +v4 = ''' +a very long +string +''' +" + (python-tests-look-at "v1 =") + (should (= (save-excursion + (python-nav-end-of-statement) + (point)) + (save-excursion + (python-tests-look-at "789") + (line-end-position)))) + (python-tests-look-at "v2 =") + (should (= (save-excursion + (python-nav-end-of-statement) + (point)) + (save-excursion + (python-tests-look-at "value4)") + (line-end-position)))) + (python-tests-look-at "v3 =") + (should (= (save-excursion + (python-nav-end-of-statement) + (point)) + (save-excursion + (python-tests-look-at + "'continue previous line')") + (line-end-position)))) + (python-tests-look-at "v4 =") + (should (= (save-excursion + (python-nav-end-of-statement) + (point)) + (save-excursion + (goto-char (point-max)) + (python-util-forward-comment -1) + (point)))))) + +(ert-deftest python-nav-forward-statement-1 () + (python-tests-with-temp-buffer + " +v1 = 123 + \ + 456 + \ + 789 +v2 = (value1, + value2, + + value3, + value4) +v3 = ('this is a string' + + 'that is continued' + 'between lines' + 'within a paren', + # this is a comment, yo + 'continue previous line') +v4 = ''' +a very long +string +''' +" + (python-tests-look-at "v1 =") + (should (= (save-excursion + (python-nav-forward-statement) + (point)) + (python-tests-look-at "v2 ="))) + (should (= (save-excursion + (python-nav-forward-statement) + (point)) + (python-tests-look-at "v3 ="))) + (should (= (save-excursion + (python-nav-forward-statement) + (point)) + (python-tests-look-at "v4 ="))) + (should (= (save-excursion + (python-nav-forward-statement) + (point)) + (point-max))))) + +(ert-deftest python-nav-backward-statement-1 () + (python-tests-with-temp-buffer + " +v1 = 123 + \ + 456 + \ + 789 +v2 = (value1, + value2, + + value3, + value4) +v3 = ('this is a string' + + 'that is continued' + 'between lines' + 'within a paren', + # this is a comment, yo + 'continue previous line') +v4 = ''' +a very long +string +''' +" + (goto-char (point-max)) + (should (= (save-excursion + (python-nav-backward-statement) + (point)) + (python-tests-look-at "v4 =" -1))) + (should (= (save-excursion + (python-nav-backward-statement) + (point)) + (python-tests-look-at "v3 =" -1))) + (should (= (save-excursion + (python-nav-backward-statement) + (point)) + (python-tests-look-at "v2 =" -1))) + (should (= (save-excursion + (python-nav-backward-statement) + (point)) + (python-tests-look-at "v1 =" -1))))) + +(ert-deftest python-nav-backward-statement-2 () + :expected-result :failed + (python-tests-with-temp-buffer + " +v1 = 123 + \ + 456 + \ + 789 +v2 = (value1, + value2, + + value3, + value4) +" + ;; FIXME: For some reason `python-nav-backward-statement' is moving + ;; back two sentences when starting from 'value4)'. + (goto-char (point-max)) + (python-util-forward-comment -1) + (should (= (save-excursion + (python-nav-backward-statement) + (point)) + (python-tests-look-at "v2 =" -1 t))))) + +(ert-deftest python-nav-beginning-of-block-1 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (python-tests-look-at "return wwrap") + (should (= (save-excursion + (python-nav-beginning-of-block) + (point)) + (python-tests-look-at "def decoratorFunctionWithArguments" -1))) + (python-tests-look-at "print 'Inside wwrap()'") + (should (= (save-excursion + (python-nav-beginning-of-block) + (point)) + (python-tests-look-at "def wwrap(f):" -1))) + (python-tests-look-at "print 'After f(*args)'") + (end-of-line) + (should (= (save-excursion + (python-nav-beginning-of-block) + (point)) + (python-tests-look-at "def wrapped_f(*args):" -1))) + (python-tests-look-at "return wrapped_f") + (should (= (save-excursion + (python-nav-beginning-of-block) + (point)) + (python-tests-look-at "def wwrap(f):" -1))))) + +(ert-deftest python-nav-end-of-block-1 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (python-tests-look-at "def decoratorFunctionWithArguments") + (should (= (save-excursion + (python-nav-end-of-block) + (point)) + (save-excursion + (goto-char (point-max)) + (python-util-forward-comment -1) + (point)))) + (python-tests-look-at "def wwrap(f):") + (should (= (save-excursion + (python-nav-end-of-block) + (point)) + (save-excursion + (python-tests-look-at "return wrapped_f") + (line-end-position)))) + (end-of-line) + (should (= (save-excursion + (python-nav-end-of-block) + (point)) + (save-excursion + (python-tests-look-at "return wrapped_f") + (line-end-position)))) + (python-tests-look-at "f(*args)") + (should (= (save-excursion + (python-nav-end-of-block) + (point)) + (save-excursion + (python-tests-look-at "print 'After f(*args)'") + (line-end-position)))))) + +(ert-deftest python-nav-forward-block-1 () + "This also accounts as a test for `python-nav-backward-block'." + (python-tests-with-temp-buffer + " +if request.user.is_authenticated(): + # def block(): + # pass + try: + profile = request.user.get_profile() + except Profile.DoesNotExist: + profile = Profile.objects.create(user=request.user) + else: + if profile.stats: + profile.recalculate_stats() + else: + profile.clear_stats() + finally: + profile.views += 1 + profile.save() +" + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "if request.user.is_authenticated():"))) + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "try:"))) + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "except Profile.DoesNotExist:"))) + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "else:"))) + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "if profile.stats:"))) + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "else:"))) + (should (= (save-excursion (python-nav-forward-block)) + (python-tests-look-at "finally:"))) + ;; When point is at the last block, leave it there and return nil + (should (not (save-excursion (python-nav-forward-block)))) + ;; Move backwards, and even if the number of moves is less than the + ;; provided argument return the point. + (should (= (save-excursion (python-nav-forward-block -10)) + (python-tests-look-at + "if request.user.is_authenticated():" -1))))) + +(ert-deftest python-nav-forward-sexp-1 () + (python-tests-with-temp-buffer + " +a() +b() +c() +" + (python-tests-look-at "a()") + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (beginning-of-line) + (looking-at "a()"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (beginning-of-line) + (looking-at "b()"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (beginning-of-line) + (looking-at "c()"))) + ;; The default behavior when next to a paren should do what lisp + ;; does and, otherwise `blink-matching-open' breaks. + (python-nav-forward-sexp -1) + (should (looking-at "()")) + (should (save-excursion + (beginning-of-line) + (looking-at "c()"))) + (end-of-line) + ;; Skipping parens should jump to `bolp' + (python-nav-forward-sexp -1 nil t) + (should (looking-at "c()")) + (forward-line -1) + (end-of-line) + ;; b() + (python-nav-forward-sexp -1) + (should (looking-at "()")) + (python-nav-forward-sexp -1) + (should (looking-at "b()")) + (end-of-line) + (python-nav-forward-sexp -1 nil t) + (should (looking-at "b()")) + (forward-line -1) + (end-of-line) + ;; a() + (python-nav-forward-sexp -1) + (should (looking-at "()")) + (python-nav-forward-sexp -1) + (should (looking-at "a()")) + (end-of-line) + (python-nav-forward-sexp -1 nil t) + (should (looking-at "a()")))) + +(ert-deftest python-nav-forward-sexp-2 () + (python-tests-with-temp-buffer + " +def func(): + if True: + aaa = bbb + ccc = ddd + eee = fff + return ggg +" + (python-tests-look-at "aa =") + (python-nav-forward-sexp) + (should (looking-at " = bbb")) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (back-to-indentation) + (looking-at "aaa = bbb"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (back-to-indentation) + (looking-at "ccc = ddd"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (back-to-indentation) + (looking-at "eee = fff"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should (save-excursion + (back-to-indentation) + (looking-at "return ggg"))) + (python-nav-forward-sexp -1) + (should (looking-at "def func():")))) + +(ert-deftest python-nav-forward-sexp-3 () + (python-tests-with-temp-buffer + " +from some_module import some_sub_module +from another_module import another_sub_module + +def another_statement(): + pass +" + (python-tests-look-at "some_module") + (python-nav-forward-sexp) + (should (looking-at " import")) + (python-nav-forward-sexp) + (should (looking-at " some_sub_module")) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should + (save-excursion + (back-to-indentation) + (looking-at + "from some_module import some_sub_module"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should + (save-excursion + (back-to-indentation) + (looking-at + "from another_module import another_sub_module"))) + (python-nav-forward-sexp) + (should (looking-at "$")) + (should + (save-excursion + (back-to-indentation) + (looking-at + "pass"))) + (python-nav-forward-sexp -1) + (should (looking-at "def another_statement():")) + (python-nav-forward-sexp -1) + (should (looking-at "from another_module import another_sub_module")) + (python-nav-forward-sexp -1) + (should (looking-at "from some_module import some_sub_module")))) + +(ert-deftest python-nav-forward-sexp-safe-1 () + (python-tests-with-temp-buffer + " +profile = Profile.objects.create(user=request.user) +profile.notify() +" + (python-tests-look-at "profile =") + (python-nav-forward-sexp-safe 1) + (should (looking-at "$")) + (beginning-of-line 1) + (python-tests-look-at "user=request.user") + (python-nav-forward-sexp-safe -1) + (should (looking-at "(user=request.user)")) + (python-nav-forward-sexp-safe -4) + (should (looking-at "profile =")) + (python-tests-look-at "user=request.user") + (python-nav-forward-sexp-safe 3) + (should (looking-at ")")) + (python-nav-forward-sexp-safe 1) + (should (looking-at "$")) + (python-nav-forward-sexp-safe 1) + (should (looking-at "$")))) + +(ert-deftest python-nav-up-list-1 () + (python-tests-with-temp-buffer + " +def f(): + if True: + return [i for i in range(3)] +" + (python-tests-look-at "3)]") + (python-nav-up-list) + (should (looking-at "]")) + (python-nav-up-list) + (should (looking-at "$")))) + +(ert-deftest python-nav-backward-up-list-1 () + :expected-result :failed + (python-tests-with-temp-buffer + " +def f(): + if True: + return [i for i in range(3)] +" + (python-tests-look-at "3)]") + (python-nav-backward-up-list) + (should (looking-at "(3)\\]")) + (python-nav-backward-up-list) + (should (looking-at + "\\[i for i in range(3)\\]")) + ;; FIXME: Need to move to beginning-of-statement. + (python-nav-backward-up-list) + (should (looking-at + "return \\[i for i in range(3)\\]")) + (python-nav-backward-up-list) + (should (looking-at "if True:")) + (python-nav-backward-up-list) + (should (looking-at "def f():")))) + +(ert-deftest python-indent-dedent-line-backspace-1 () + "Check de-indentation on first call. Bug#18319." + (python-tests-with-temp-buffer + " +if True: + x () + if False: +" + (python-tests-look-at "if False:") + (call-interactively #'python-indent-dedent-line-backspace) + (should (zerop (current-indentation))) + ;; XXX: This should be a call to `undo' but it's triggering errors. + (insert " ") + (should (= (current-indentation) 4)) + (call-interactively #'python-indent-dedent-line-backspace) + (should (zerop (current-indentation))))) + +(ert-deftest python-indent-dedent-line-backspace-2 () + "Check de-indentation with tabs. Bug#19730." + (let ((tab-width 8)) + (python-tests-with-temp-buffer + " +if x: +\tabcdefg +" + (python-tests-look-at "abcdefg") + (goto-char (line-end-position)) + (call-interactively #'python-indent-dedent-line-backspace) + (should + (string= (buffer-substring-no-properties + (line-beginning-position) (line-end-position)) + "\tabcdef"))))) + +(ert-deftest python-indent-dedent-line-backspace-3 () + "Paranoid check of de-indentation with tabs. Bug#19730." + (let ((tab-width 8)) + (python-tests-with-temp-buffer + " +if x: +\tif y: +\t abcdefg +" + (python-tests-look-at "abcdefg") + (goto-char (line-end-position)) + (call-interactively #'python-indent-dedent-line-backspace) + (should + (string= (buffer-substring-no-properties + (line-beginning-position) (line-end-position)) + "\t abcdef")) + (back-to-indentation) + (call-interactively #'python-indent-dedent-line-backspace) + (should + (string= (buffer-substring-no-properties + (line-beginning-position) (line-end-position)) + "\tabcdef")) + (call-interactively #'python-indent-dedent-line-backspace) + (should + (string= (buffer-substring-no-properties + (line-beginning-position) (line-end-position)) + " abcdef")) + (call-interactively #'python-indent-dedent-line-backspace) + (should + (string= (buffer-substring-no-properties + (line-beginning-position) (line-end-position)) + "abcdef"))))) + +(ert-deftest python-bob-infloop-avoid () + "Test that strings at BOB don't confuse syntax analysis. Bug#24905" + (python-tests-with-temp-buffer + " \"\n" + (goto-char (point-min)) + (font-lock-fontify-buffer))) + + +;;; Shell integration + +(defvar python-tests-shell-interpreter "python") + +(ert-deftest python-shell-get-process-name-1 () + "Check process name calculation sans `buffer-file-name'." + (python-tests-with-temp-buffer + "" + (should (string= (python-shell-get-process-name nil) + python-shell-buffer-name)) + (should (string= (python-shell-get-process-name t) + (format "%s[%s]" python-shell-buffer-name (buffer-name)))))) + +(ert-deftest python-shell-get-process-name-2 () + "Check process name calculation with `buffer-file-name'." + (python-tests-with-temp-file + "" + ;; `buffer-file-name' is non-nil but the dedicated flag is nil and + ;; should be respected. + (should (string= (python-shell-get-process-name nil) + python-shell-buffer-name)) + (should (string= + (python-shell-get-process-name t) + (format "%s[%s]" python-shell-buffer-name (buffer-name)))))) + +(ert-deftest python-shell-internal-get-process-name-1 () + "Check the internal process name is buffer-unique sans `buffer-file-name'." + (python-tests-with-temp-buffer + "" + (should (string= (python-shell-internal-get-process-name) + (format "%s[%s]" python-shell-internal-buffer-name (buffer-name)))))) + +(ert-deftest python-shell-internal-get-process-name-2 () + "Check the internal process name is buffer-unique with `buffer-file-name'." + (python-tests-with-temp-file + "" + (should (string= (python-shell-internal-get-process-name) + (format "%s[%s]" python-shell-internal-buffer-name (buffer-name)))))) + +(ert-deftest python-shell-calculate-command-1 () + "Check the command to execute is calculated correctly. +Using `python-shell-interpreter' and +`python-shell-interpreter-args'." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let ((python-shell-interpreter (executable-find + python-tests-shell-interpreter)) + (python-shell-interpreter-args "-B")) + (should (string= + (format "%s %s" + (shell-quote-argument python-shell-interpreter) + python-shell-interpreter-args) + (python-shell-calculate-command))))) + +(ert-deftest python-shell-calculate-pythonpath-1 () + "Test PYTHONPATH calculation." + (let ((process-environment '("PYTHONPATH=/path0")) + (python-shell-extra-pythonpaths '("/path1" "/path2"))) + (should (string= (python-shell-calculate-pythonpath) + (concat "/path1" path-separator + "/path2" path-separator "/path0"))))) + +(ert-deftest python-shell-calculate-pythonpath-2 () + "Test existing paths are moved to front." + (let ((process-environment + (list (concat "PYTHONPATH=/path0" path-separator "/path1"))) + (python-shell-extra-pythonpaths '("/path1" "/path2"))) + (should (string= (python-shell-calculate-pythonpath) + (concat "/path1" path-separator + "/path2" path-separator "/path0"))))) + +(ert-deftest python-shell-calculate-process-environment-1 () + "Test `python-shell-process-environment' modification." + (let* ((python-shell-process-environment + '("TESTVAR1=value1" "TESTVAR2=value2")) + (process-environment (python-shell-calculate-process-environment))) + (should (equal (getenv "TESTVAR1") "value1")) + (should (equal (getenv "TESTVAR2") "value2")))) + +(ert-deftest python-shell-calculate-process-environment-2 () + "Test `python-shell-extra-pythonpaths' modification." + (let* ((process-environment process-environment) + (original-pythonpath (setenv "PYTHONPATH" "/path0")) + (python-shell-extra-pythonpaths '("/path1" "/path2")) + (process-environment (python-shell-calculate-process-environment))) + (should (equal (getenv "PYTHONPATH") + (concat "/path1" path-separator + "/path2" path-separator "/path0"))))) + +(ert-deftest python-shell-calculate-process-environment-3 () + "Test `python-shell-virtualenv-root' modification." + (let* ((python-shell-virtualenv-root "/env") + (process-environment + (let (process-environment process-environment) + (setenv "PYTHONHOME" "/home") + (setenv "VIRTUAL_ENV") + (python-shell-calculate-process-environment)))) + (should (not (getenv "PYTHONHOME"))) + (should (string= (getenv "VIRTUAL_ENV") "/env")))) + +(ert-deftest python-shell-calculate-process-environment-4 () + "Test PYTHONUNBUFFERED when `python-shell-unbuffered' is non-nil." + (let* ((python-shell-unbuffered t) + (process-environment + (let ((process-environment process-environment)) + (setenv "PYTHONUNBUFFERED") + (python-shell-calculate-process-environment)))) + (should (string= (getenv "PYTHONUNBUFFERED") "1")))) + +(ert-deftest python-shell-calculate-process-environment-5 () + "Test PYTHONUNBUFFERED when `python-shell-unbuffered' is nil." + (let* ((python-shell-unbuffered nil) + (process-environment + (let ((process-environment process-environment)) + (setenv "PYTHONUNBUFFERED") + (python-shell-calculate-process-environment)))) + (should (not (getenv "PYTHONUNBUFFERED"))))) + +(ert-deftest python-shell-calculate-process-environment-6 () + "Test PYTHONUNBUFFERED=1 when `python-shell-unbuffered' is nil." + (let* ((python-shell-unbuffered nil) + (process-environment + (let ((process-environment process-environment)) + (setenv "PYTHONUNBUFFERED" "1") + (python-shell-calculate-process-environment)))) + ;; User default settings must remain untouched: + (should (string= (getenv "PYTHONUNBUFFERED") "1")))) + +(ert-deftest python-shell-calculate-process-environment-7 () + "Test no side-effects on `process-environment'." + (let* ((python-shell-process-environment + '("TESTVAR1=value1" "TESTVAR2=value2")) + (python-shell-virtualenv-root "/env") + (python-shell-unbuffered t) + (python-shell-extra-pythonpaths'("/path1" "/path2")) + (original-process-environment (copy-sequence process-environment))) + (python-shell-calculate-process-environment) + (should (equal process-environment original-process-environment)))) + +(ert-deftest python-shell-calculate-process-environment-8 () + "Test no side-effects on `tramp-remote-process-environment'." + (let* ((default-directory "/ssh::/example/dir/") + (python-shell-process-environment + '("TESTVAR1=value1" "TESTVAR2=value2")) + (python-shell-virtualenv-root "/env") + (python-shell-unbuffered t) + (python-shell-extra-pythonpaths'("/path1" "/path2")) + (original-process-environment + (copy-sequence tramp-remote-process-environment))) + (python-shell-calculate-process-environment) + (should (equal tramp-remote-process-environment original-process-environment)))) + +(ert-deftest python-shell-calculate-exec-path-1 () + "Test `python-shell-exec-path' modification." + (let* ((exec-path '("/path0")) + (python-shell-exec-path '("/path1" "/path2")) + (new-exec-path (python-shell-calculate-exec-path))) + (should (equal new-exec-path '("/path1" "/path2" "/path0"))))) + +(ert-deftest python-shell-calculate-exec-path-2 () + "Test `python-shell-virtualenv-root' modification." + (let* ((exec-path '("/path0")) + (python-shell-virtualenv-root "/env") + (new-exec-path (python-shell-calculate-exec-path))) + (should (equal new-exec-path + (list (expand-file-name "/env/bin") "/path0"))))) + +(ert-deftest python-shell-calculate-exec-path-3 () + "Test complete `python-shell-virtualenv-root' modification." + (let* ((exec-path '("/path0")) + (python-shell-exec-path '("/path1" "/path2")) + (python-shell-virtualenv-root "/env") + (new-exec-path (python-shell-calculate-exec-path))) + (should (equal new-exec-path + (list (expand-file-name "/env/bin") + "/path1" "/path2" "/path0"))))) + +(ert-deftest python-shell-calculate-exec-path-4 () + "Test complete `python-shell-virtualenv-root' with remote." + (let* ((default-directory "/ssh::/example/dir/") + (python-shell-remote-exec-path '("/path0")) + (python-shell-exec-path '("/path1" "/path2")) + (python-shell-virtualenv-root "/env") + (new-exec-path (python-shell-calculate-exec-path))) + (should (equal new-exec-path + (list (expand-file-name "/env/bin") + "/path1" "/path2" "/path0"))))) + +(ert-deftest python-shell-calculate-exec-path-5 () + "Test no side-effects on `exec-path'." + (let* ((exec-path '("/path0")) + (python-shell-exec-path '("/path1" "/path2")) + (python-shell-virtualenv-root "/env") + (original-exec-path (copy-sequence exec-path))) + (python-shell-calculate-exec-path) + (should (equal exec-path original-exec-path)))) + +(ert-deftest python-shell-calculate-exec-path-6 () + "Test no side-effects on `python-shell-remote-exec-path'." + (let* ((default-directory "/ssh::/example/dir/") + (python-shell-remote-exec-path '("/path0")) + (python-shell-exec-path '("/path1" "/path2")) + (python-shell-virtualenv-root "/env") + (original-exec-path (copy-sequence python-shell-remote-exec-path))) + (python-shell-calculate-exec-path) + (should (equal python-shell-remote-exec-path original-exec-path)))) + +(ert-deftest python-shell-with-environment-1 () + "Test environment with local `default-directory'." + (let* ((exec-path '("/path0")) + (python-shell-exec-path '("/path1" "/path2")) + (original-exec-path exec-path) + (python-shell-virtualenv-root "/env")) + (python-shell-with-environment + (should (equal exec-path + (list (expand-file-name "/env/bin") + "/path1" "/path2" "/path0"))) + (should (not (getenv "PYTHONHOME"))) + (should (string= (getenv "VIRTUAL_ENV") "/env"))) + (should (equal exec-path original-exec-path)))) + +(ert-deftest python-shell-with-environment-2 () + "Test environment with remote `default-directory'." + (let* ((default-directory "/ssh::/example/dir/") + (python-shell-remote-exec-path '("/remote1" "/remote2")) + (python-shell-exec-path '("/path1" "/path2")) + (tramp-remote-process-environment '("EMACS=t")) + (original-process-environment (copy-sequence tramp-remote-process-environment)) + (python-shell-virtualenv-root "/env")) + (python-shell-with-environment + (should (equal (python-shell-calculate-exec-path) + (list (expand-file-name "/env/bin") + "/path1" "/path2" "/remote1" "/remote2"))) + (let ((process-environment (python-shell-calculate-process-environment))) + (should (not (getenv "PYTHONHOME"))) + (should (string= (getenv "VIRTUAL_ENV") "/env")) + (should (equal tramp-remote-process-environment process-environment)))) + (should (equal tramp-remote-process-environment original-process-environment)))) + +(ert-deftest python-shell-with-environment-3 () + "Test `python-shell-with-environment' is idempotent." + (let* ((python-shell-extra-pythonpaths '("/example/dir/")) + (python-shell-exec-path '("path1" "path2")) + (python-shell-virtualenv-root "/home/user/env") + (single-call + (python-shell-with-environment + (list exec-path process-environment))) + (nested-call + (python-shell-with-environment + (python-shell-with-environment + (list exec-path process-environment))))) + (should (equal single-call nested-call)))) + +(ert-deftest python-shell-make-comint-1 () + "Check comint creation for global shell buffer." + (skip-unless (executable-find python-tests-shell-interpreter)) + ;; The interpreter can get killed too quickly to allow it to clean + ;; up the tempfiles that the default python-shell-setup-codes create, + ;; so it leaves tempfiles behind, which is a minor irritation. + (let* ((python-shell-setup-codes nil) + (python-shell-interpreter + (executable-find python-tests-shell-interpreter)) + (proc-name (python-shell-get-process-name nil)) + (shell-buffer + (python-tests-with-temp-buffer + "" (python-shell-make-comint + (python-shell-calculate-command) proc-name))) + (process (get-buffer-process shell-buffer))) + (unwind-protect + (progn + (set-process-query-on-exit-flag process nil) + (should (process-live-p process)) + (with-current-buffer shell-buffer + (should (eq major-mode 'inferior-python-mode)) + (should (string= (buffer-name) (format "*%s*" proc-name))))) + (kill-buffer shell-buffer)))) + +(ert-deftest python-shell-make-comint-2 () + "Check comint creation for internal shell buffer." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((python-shell-setup-codes nil) + (python-shell-interpreter + (executable-find python-tests-shell-interpreter)) + (proc-name (python-shell-internal-get-process-name)) + (shell-buffer + (python-tests-with-temp-buffer + "" (python-shell-make-comint + (python-shell-calculate-command) proc-name nil t))) + (process (get-buffer-process shell-buffer))) + (unwind-protect + (progn + (set-process-query-on-exit-flag process nil) + (should (process-live-p process)) + (with-current-buffer shell-buffer + (should (eq major-mode 'inferior-python-mode)) + (should (string= (buffer-name) (format " *%s*" proc-name))))) + (kill-buffer shell-buffer)))) + +(ert-deftest python-shell-make-comint-3 () + "Check comint creation with overridden python interpreter and args. +The command passed to `python-shell-make-comint' as argument must +locally override global values set in `python-shell-interpreter' +and `python-shell-interpreter-args' in the new shell buffer." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((python-shell-setup-codes nil) + (python-shell-interpreter "interpreter") + (python-shell-interpreter-args "--some-args") + (proc-name (python-shell-get-process-name nil)) + (interpreter-override + (concat (executable-find python-tests-shell-interpreter) " " "-i")) + (shell-buffer + (python-tests-with-temp-buffer + "" (python-shell-make-comint interpreter-override proc-name nil))) + (process (get-buffer-process shell-buffer))) + (unwind-protect + (progn + (set-process-query-on-exit-flag process nil) + (should (process-live-p process)) + (with-current-buffer shell-buffer + (should (eq major-mode 'inferior-python-mode)) + (should (file-equal-p + python-shell-interpreter + (executable-find python-tests-shell-interpreter))) + (should (string= python-shell-interpreter-args "-i")))) + (kill-buffer shell-buffer)))) + +(ert-deftest python-shell-make-comint-4 () + "Check shell calculated prompts regexps are set." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((process-environment process-environment) + (python-shell-setup-codes nil) + (python-shell-interpreter + (executable-find python-tests-shell-interpreter)) + (python-shell-interpreter-args "-i") + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled t) + (python-shell-prompt-input-regexps '("extralargeinputprompt" "sml")) + (python-shell-prompt-output-regexps '("extralargeoutputprompt" "sml")) + (python-shell-prompt-regexp "in") + (python-shell-prompt-block-regexp "block") + (python-shell-prompt-pdb-regexp "pdf") + (python-shell-prompt-output-regexp "output") + (startup-code (concat "import sys\n" + "sys.ps1 = 'py> '\n" + "sys.ps2 = '..> '\n" + "sys.ps3 = 'out '\n")) + (startup-file (python-shell--save-temp-file startup-code)) + (proc-name (python-shell-get-process-name nil)) + (shell-buffer + (progn + (setenv "PYTHONSTARTUP" startup-file) + (python-tests-with-temp-buffer + "" (python-shell-make-comint + (python-shell-calculate-command) proc-name nil)))) + (process (get-buffer-process shell-buffer))) + (unwind-protect + (progn + (set-process-query-on-exit-flag process nil) + (should (process-live-p process)) + (with-current-buffer shell-buffer + (should (eq major-mode 'inferior-python-mode)) + (should (string= + python-shell--prompt-calculated-input-regexp + (concat "^\\(extralargeinputprompt\\|\\.\\.> \\|" + "block\\|py> \\|pdf\\|sml\\|in\\)"))) + (should (string= + python-shell--prompt-calculated-output-regexp + "^\\(extralargeoutputprompt\\|output\\|out \\|sml\\)")))) + (delete-file startup-file) + (kill-buffer shell-buffer)))) + +(ert-deftest python-shell-get-process-1 () + "Check dedicated shell process preference over global." + (skip-unless (executable-find python-tests-shell-interpreter)) + (python-tests-with-temp-file + "" + (let* ((python-shell-setup-codes nil) + (python-shell-interpreter + (executable-find python-tests-shell-interpreter)) + (global-proc-name (python-shell-get-process-name nil)) + (dedicated-proc-name (python-shell-get-process-name t)) + (global-shell-buffer + (python-shell-make-comint + (python-shell-calculate-command) global-proc-name)) + (dedicated-shell-buffer + (python-shell-make-comint + (python-shell-calculate-command) dedicated-proc-name)) + (global-process (get-buffer-process global-shell-buffer)) + (dedicated-process (get-buffer-process dedicated-shell-buffer))) + (unwind-protect + (progn + (set-process-query-on-exit-flag global-process nil) + (set-process-query-on-exit-flag dedicated-process nil) + ;; Prefer dedicated if global also exists. + (should (equal (python-shell-get-process) dedicated-process)) + (kill-buffer dedicated-shell-buffer) + ;; If there's only global, use it. + (should (equal (python-shell-get-process) global-process)) + (kill-buffer global-shell-buffer) + ;; No buffer available. + (should (not (python-shell-get-process)))) + (ignore-errors (kill-buffer global-shell-buffer)) + (ignore-errors (kill-buffer dedicated-shell-buffer)))))) + +(ert-deftest python-shell-internal-get-or-create-process-1 () + "Check internal shell process creation fallback." + (skip-unless (executable-find python-tests-shell-interpreter)) + (python-tests-with-temp-file + "" + (should (not (process-live-p (python-shell-internal-get-process-name)))) + (let* ((python-shell-interpreter + (executable-find python-tests-shell-interpreter)) + (internal-process-name (python-shell-internal-get-process-name)) + (internal-process (python-shell-internal-get-or-create-process)) + (internal-shell-buffer (process-buffer internal-process))) + (unwind-protect + (progn + (set-process-query-on-exit-flag internal-process nil) + (should (equal (process-name internal-process) + internal-process-name)) + (should (equal internal-process + (python-shell-internal-get-or-create-process))) + ;; Assert the internal process is not a user process + (should (not (python-shell-get-process))) + (kill-buffer internal-shell-buffer)) + (ignore-errors (kill-buffer internal-shell-buffer)))))) + +(ert-deftest python-shell-prompt-detect-1 () + "Check prompt autodetection." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let ((process-environment process-environment)) + ;; Ensure no startup file is enabled + (setenv "PYTHONSTARTUP" "") + (should python-shell-prompt-detect-enabled) + (should (equal (python-shell-prompt-detect) '(">>> " "... " ""))))) + +(ert-deftest python-shell-prompt-detect-2 () + "Check prompt autodetection with startup file. Bug#17370." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((process-environment process-environment) + (startup-code (concat "import sys\n" + "sys.ps1 = 'py> '\n" + "sys.ps2 = '..> '\n" + "sys.ps3 = 'out '\n")) + (startup-file (python-shell--save-temp-file startup-code))) + (unwind-protect + (progn + ;; Ensure startup file is enabled + (setenv "PYTHONSTARTUP" startup-file) + (should python-shell-prompt-detect-enabled) + (should (equal (python-shell-prompt-detect) '("py> " "..> " "out ")))) + (ignore-errors (delete-file startup-file))))) + +(ert-deftest python-shell-prompt-detect-3 () + "Check prompts are not autodetected when feature is disabled." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let ((process-environment process-environment) + (python-shell-prompt-detect-enabled nil)) + ;; Ensure no startup file is enabled + (should (not python-shell-prompt-detect-enabled)) + (should (not (python-shell-prompt-detect))))) + +(ert-deftest python-shell-prompt-detect-4 () + "Check warning is shown when detection fails." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((process-environment process-environment) + ;; Trigger failure by removing prompts in the startup file + (startup-code (concat "import sys\n" + "sys.ps1 = ''\n" + "sys.ps2 = ''\n" + "sys.ps3 = ''\n")) + (startup-file (python-shell--save-temp-file startup-code))) + (unwind-protect + (progn + (kill-buffer (get-buffer-create "*Warnings*")) + (should (not (get-buffer "*Warnings*"))) + (setenv "PYTHONSTARTUP" startup-file) + (should python-shell-prompt-detect-failure-warning) + (should python-shell-prompt-detect-enabled) + (should (not (python-shell-prompt-detect))) + (should (get-buffer "*Warnings*"))) + (ignore-errors (delete-file startup-file))))) + +(ert-deftest python-shell-prompt-detect-5 () + "Check disabled warnings are not shown when detection fails." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((process-environment process-environment) + (startup-code (concat "import sys\n" + "sys.ps1 = ''\n" + "sys.ps2 = ''\n" + "sys.ps3 = ''\n")) + (startup-file (python-shell--save-temp-file startup-code)) + (python-shell-prompt-detect-failure-warning nil)) + (unwind-protect + (progn + (kill-buffer (get-buffer-create "*Warnings*")) + (should (not (get-buffer "*Warnings*"))) + (setenv "PYTHONSTARTUP" startup-file) + (should (not python-shell-prompt-detect-failure-warning)) + (should python-shell-prompt-detect-enabled) + (should (not (python-shell-prompt-detect))) + (should (not (get-buffer "*Warnings*")))) + (ignore-errors (delete-file startup-file))))) + +(ert-deftest python-shell-prompt-detect-6 () + "Warnings are not shown when detection is disabled." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((process-environment process-environment) + (startup-code (concat "import sys\n" + "sys.ps1 = ''\n" + "sys.ps2 = ''\n" + "sys.ps3 = ''\n")) + (startup-file (python-shell--save-temp-file startup-code)) + (python-shell-prompt-detect-failure-warning t) + (python-shell-prompt-detect-enabled nil)) + (unwind-protect + (progn + (kill-buffer (get-buffer-create "*Warnings*")) + (should (not (get-buffer "*Warnings*"))) + (setenv "PYTHONSTARTUP" startup-file) + (should python-shell-prompt-detect-failure-warning) + (should (not python-shell-prompt-detect-enabled)) + (should (not (python-shell-prompt-detect))) + (should (not (get-buffer "*Warnings*")))) + (ignore-errors (delete-file startup-file))))) + +(ert-deftest python-shell-prompt-validate-regexps-1 () + "Check `python-shell-prompt-input-regexps' are validated." + (let* ((python-shell-prompt-input-regexps '("\\(")) + (error-data (should-error (python-shell-prompt-validate-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-input-regexps'"))))) + +(ert-deftest python-shell-prompt-validate-regexps-2 () + "Check `python-shell-prompt-output-regexps' are validated." + (let* ((python-shell-prompt-output-regexps '("\\(")) + (error-data (should-error (python-shell-prompt-validate-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-output-regexps'"))))) + +(ert-deftest python-shell-prompt-validate-regexps-3 () + "Check `python-shell-prompt-regexp' is validated." + (let* ((python-shell-prompt-regexp "\\(") + (error-data (should-error (python-shell-prompt-validate-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-regexp'"))))) + +(ert-deftest python-shell-prompt-validate-regexps-4 () + "Check `python-shell-prompt-block-regexp' is validated." + (let* ((python-shell-prompt-block-regexp "\\(") + (error-data (should-error (python-shell-prompt-validate-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-block-regexp'"))))) + +(ert-deftest python-shell-prompt-validate-regexps-5 () + "Check `python-shell-prompt-pdb-regexp' is validated." + (let* ((python-shell-prompt-pdb-regexp "\\(") + (error-data (should-error (python-shell-prompt-validate-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-pdb-regexp'"))))) + +(ert-deftest python-shell-prompt-validate-regexps-6 () + "Check `python-shell-prompt-output-regexp' is validated." + (let* ((python-shell-prompt-output-regexp "\\(") + (error-data (should-error (python-shell-prompt-validate-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-output-regexp'"))))) + +(ert-deftest python-shell-prompt-validate-regexps-7 () + "Check default regexps are valid." + ;; should not signal error + (python-shell-prompt-validate-regexps)) + +(ert-deftest python-shell-prompt-set-calculated-regexps-1 () + "Check regexps are validated." + (let* ((python-shell-prompt-output-regexp '("\\(")) + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled nil) + (error-data (should-error (python-shell-prompt-set-calculated-regexps) + :type 'user-error))) + (should + (string= (cadr error-data) + (format-message + "Invalid regexp \\( in `python-shell-prompt-output-regexp'"))))) + +(ert-deftest python-shell-prompt-set-calculated-regexps-2 () + "Check `python-shell-prompt-input-regexps' are set." + (let* ((python-shell-prompt-input-regexps '("my" "prompt")) + (python-shell-prompt-output-regexps '("")) + (python-shell-prompt-regexp "") + (python-shell-prompt-block-regexp "") + (python-shell-prompt-pdb-regexp "") + (python-shell-prompt-output-regexp "") + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled nil)) + (python-shell-prompt-set-calculated-regexps) + (should (string= python-shell--prompt-calculated-input-regexp + "^\\(prompt\\|my\\|\\)")))) + +(ert-deftest python-shell-prompt-set-calculated-regexps-3 () + "Check `python-shell-prompt-output-regexps' are set." + (let* ((python-shell-prompt-input-regexps '("")) + (python-shell-prompt-output-regexps '("my" "prompt")) + (python-shell-prompt-regexp "") + (python-shell-prompt-block-regexp "") + (python-shell-prompt-pdb-regexp "") + (python-shell-prompt-output-regexp "") + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled nil)) + (python-shell-prompt-set-calculated-regexps) + (should (string= python-shell--prompt-calculated-output-regexp + "^\\(prompt\\|my\\|\\)")))) + +(ert-deftest python-shell-prompt-set-calculated-regexps-4 () + "Check user defined prompts are set." + (let* ((python-shell-prompt-input-regexps '("")) + (python-shell-prompt-output-regexps '("")) + (python-shell-prompt-regexp "prompt") + (python-shell-prompt-block-regexp "block") + (python-shell-prompt-pdb-regexp "pdb") + (python-shell-prompt-output-regexp "output") + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled nil)) + (python-shell-prompt-set-calculated-regexps) + (should (string= python-shell--prompt-calculated-input-regexp + "^\\(prompt\\|block\\|pdb\\|\\)")) + (should (string= python-shell--prompt-calculated-output-regexp + "^\\(output\\|\\)")))) + +(ert-deftest python-shell-prompt-set-calculated-regexps-5 () + "Check order of regexps (larger first)." + (let* ((python-shell-prompt-input-regexps '("extralargeinputprompt" "sml")) + (python-shell-prompt-output-regexps '("extralargeoutputprompt" "sml")) + (python-shell-prompt-regexp "in") + (python-shell-prompt-block-regexp "block") + (python-shell-prompt-pdb-regexp "pdf") + (python-shell-prompt-output-regexp "output") + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled nil)) + (python-shell-prompt-set-calculated-regexps) + (should (string= python-shell--prompt-calculated-input-regexp + "^\\(extralargeinputprompt\\|block\\|pdf\\|sml\\|in\\)")) + (should (string= python-shell--prompt-calculated-output-regexp + "^\\(extralargeoutputprompt\\|output\\|sml\\)")))) + +(ert-deftest python-shell-prompt-set-calculated-regexps-6 () + "Check detected prompts are included `regexp-quote'd." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let* ((python-shell-prompt-input-regexps '("")) + (python-shell-prompt-output-regexps '("")) + (python-shell-prompt-regexp "") + (python-shell-prompt-block-regexp "") + (python-shell-prompt-pdb-regexp "") + (python-shell-prompt-output-regexp "") + (python-shell--prompt-calculated-input-regexp nil) + (python-shell--prompt-calculated-output-regexp nil) + (python-shell-prompt-detect-enabled t) + (process-environment process-environment) + (startup-code (concat "import sys\n" + "sys.ps1 = 'p.> '\n" + "sys.ps2 = '..> '\n" + "sys.ps3 = 'o.t '\n")) + (startup-file (python-shell--save-temp-file startup-code))) + (unwind-protect + (progn + (setenv "PYTHONSTARTUP" startup-file) + (python-shell-prompt-set-calculated-regexps) + (should (string= python-shell--prompt-calculated-input-regexp + "^\\(\\.\\.> \\|p\\.> \\|\\)")) + (should (string= python-shell--prompt-calculated-output-regexp + "^\\(o\\.t \\|\\)"))) + (ignore-errors (delete-file startup-file))))) + +(ert-deftest python-shell-buffer-substring-1 () + "Selecting a substring of the whole buffer must match its contents." + (python-tests-with-temp-buffer + " +class Foo(models.Model): + pass + + +class Bar(models.Model): + pass +" + (should (string= (buffer-string) + (python-shell-buffer-substring (point-min) (point-max)))))) + +(ert-deftest python-shell-buffer-substring-2 () + "Main block should be removed if NOMAIN is non-nil." + (python-tests-with-temp-buffer + " +class Foo(models.Model): + pass + +class Bar(models.Model): + pass + +if __name__ == \"__main__\": + foo = Foo() + print (foo) +" + (should (string= (python-shell-buffer-substring (point-min) (point-max) t) + " +class Foo(models.Model): + pass + +class Bar(models.Model): + pass + + + + +")))) + +(ert-deftest python-shell-buffer-substring-3 () + "Main block should be removed if NOMAIN is non-nil." + (python-tests-with-temp-buffer + " +class Foo(models.Model): + pass + +if __name__ == \"__main__\": + foo = Foo() + print (foo) + +class Bar(models.Model): + pass +" + (should (string= (python-shell-buffer-substring (point-min) (point-max) t) + " +class Foo(models.Model): + pass + + + + + +class Bar(models.Model): + pass +")))) + +(ert-deftest python-shell-buffer-substring-4 () + "Coding cookie should be added for substrings." + (python-tests-with-temp-buffer + "# coding: latin-1 + +class Foo(models.Model): + pass + +if __name__ == \"__main__\": + foo = Foo() + print (foo) + +class Bar(models.Model): + pass +" + (should (string= (python-shell-buffer-substring + (python-tests-look-at "class Foo(models.Model):") + (progn (python-nav-forward-sexp) (point))) + "# -*- coding: latin-1 -*- + +class Foo(models.Model): + pass")))) + +(ert-deftest python-shell-buffer-substring-5 () + "The proper amount of blank lines is added for a substring." + (python-tests-with-temp-buffer + "# coding: latin-1 + +class Foo(models.Model): + pass + +if __name__ == \"__main__\": + foo = Foo() + print (foo) + +class Bar(models.Model): + pass +" + (should (string= (python-shell-buffer-substring + (python-tests-look-at "class Bar(models.Model):") + (progn (python-nav-forward-sexp) (point))) + "# -*- coding: latin-1 -*- + + + + + + + + +class Bar(models.Model): + pass")))) + +(ert-deftest python-shell-buffer-substring-6 () + "Handle substring with coding cookie in the second line." + (python-tests-with-temp-buffer + " +# coding: latin-1 + +class Foo(models.Model): + pass + +if __name__ == \"__main__\": + foo = Foo() + print (foo) + +class Bar(models.Model): + pass +" + (should (string= (python-shell-buffer-substring + (python-tests-look-at "# coding: latin-1") + (python-tests-look-at "if __name__ == \"__main__\":")) + "# -*- coding: latin-1 -*- + + +class Foo(models.Model): + pass + +")))) + +(ert-deftest python-shell-buffer-substring-7 () + "Ensure first coding cookie gets precedence." + (python-tests-with-temp-buffer + "# coding: utf-8 +# coding: latin-1 + +class Foo(models.Model): + pass + +if __name__ == \"__main__\": + foo = Foo() + print (foo) + +class Bar(models.Model): + pass +" + (should (string= (python-shell-buffer-substring + (python-tests-look-at "# coding: latin-1") + (python-tests-look-at "if __name__ == \"__main__\":")) + "# -*- coding: utf-8 -*- + + +class Foo(models.Model): + pass + +")))) + +(ert-deftest python-shell-buffer-substring-8 () + "Ensure first coding cookie gets precedence when sending whole buffer." + (python-tests-with-temp-buffer + "# coding: utf-8 +# coding: latin-1 + +class Foo(models.Model): + pass +" + (should (string= (python-shell-buffer-substring (point-min) (point-max)) + "# coding: utf-8 + + +class Foo(models.Model): + pass +")))) + +(ert-deftest python-shell-buffer-substring-9 () + "Check substring starting from `point-min'." + (python-tests-with-temp-buffer + "# coding: utf-8 + +class Foo(models.Model): + pass + +class Bar(models.Model): + pass +" + (should (string= (python-shell-buffer-substring + (point-min) + (python-tests-look-at "class Bar(models.Model):")) + "# coding: utf-8 + +class Foo(models.Model): + pass + +")))) + +(ert-deftest python-shell-buffer-substring-10 () + "Check substring from partial block." + (python-tests-with-temp-buffer + " +def foo(): + print ('a') +" + (should (string= (python-shell-buffer-substring + (python-tests-look-at "print ('a')") + (point-max)) + "if True: + + print ('a') +")))) + +(ert-deftest python-shell-buffer-substring-11 () + "Check substring from partial block and point within indentation." + (python-tests-with-temp-buffer + " +def foo(): + print ('a') +" + (should (string= (python-shell-buffer-substring + (progn + (python-tests-look-at "print ('a')") + (backward-char 1) + (point)) + (point-max)) + "if True: + + print ('a') +")))) + +(ert-deftest python-shell-buffer-substring-12 () + "Check substring from partial block and point in whitespace." + (python-tests-with-temp-buffer + " +def foo(): + + # Whitespace + + print ('a') +" + (should (string= (python-shell-buffer-substring + (python-tests-look-at "# Whitespace") + (point-max)) + "if True: + + + # Whitespace + + print ('a') +")))) + + + +;;; Shell completion + +(ert-deftest python-shell-completion-native-interpreter-disabled-p-1 () + (let* ((python-shell-completion-native-disabled-interpreters (list "pypy")) + (python-shell-interpreter "/some/path/to/bin/pypy")) + (should (python-shell-completion-native-interpreter-disabled-p)))) + + + + +;;; PDB Track integration + + +;;; Symbol completion + + +;;; Fill paragraph + + +;;; Skeletons + + +;;; FFAP + + +;;; Code check + + +;;; Eldoc + +(ert-deftest python-eldoc--get-symbol-at-point-1 () + "Test paren handling." + (python-tests-with-temp-buffer + " +map(xx +map(codecs.open('somefile' +" + (python-tests-look-at "ap(xx") + (should (string= (python-eldoc--get-symbol-at-point) "map")) + (goto-char (line-end-position)) + (should (string= (python-eldoc--get-symbol-at-point) "map")) + (python-tests-look-at "('somefile'") + (should (string= (python-eldoc--get-symbol-at-point) "map")) + (goto-char (line-end-position)) + (should (string= (python-eldoc--get-symbol-at-point) "codecs.open")))) + +(ert-deftest python-eldoc--get-symbol-at-point-2 () + "Ensure self is replaced with the class name." + (python-tests-with-temp-buffer + " +class TheClass: + + def some_method(self, n): + return n + + def other(self): + return self.some_method(1234) + +" + (python-tests-look-at "self.some_method") + (should (string= (python-eldoc--get-symbol-at-point) + "TheClass.some_method")) + (python-tests-look-at "1234)") + (should (string= (python-eldoc--get-symbol-at-point) + "TheClass.some_method")))) + +(ert-deftest python-eldoc--get-symbol-at-point-3 () + "Ensure symbol is found when point is at end of buffer." + (python-tests-with-temp-buffer + " +some_symbol + +" + (goto-char (point-max)) + (should (string= (python-eldoc--get-symbol-at-point) + "some_symbol")))) + +(ert-deftest python-eldoc--get-symbol-at-point-4 () + "Ensure symbol is found when point is at whitespace." + (python-tests-with-temp-buffer + " +some_symbol some_other_symbol +" + (python-tests-look-at " some_other_symbol") + (should (string= (python-eldoc--get-symbol-at-point) + "some_symbol")))) + + +;;; Imenu + +(ert-deftest python-imenu-create-index-1 () + (python-tests-with-temp-buffer + " +class Foo(models.Model): + pass + + +class Bar(models.Model): + pass + + +def decorator(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decorator('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wrap(f): + print ('wrap') + def wrapped_f(*args): + print ('wrapped_f') + print ('Decorator arguments:', arg1, arg2, arg3) + f(*args) + print ('called f(*args)') + return wrapped_f + return wrap + + +class Baz(object): + + def a(self): + pass + + def b(self): + pass + + class Frob(object): + + def c(self): + pass +" + (goto-char (point-max)) + (should (equal + (list + (cons "Foo (class)" (copy-marker 2)) + (cons "Bar (class)" (copy-marker 38)) + (list + "decorator (def)" + (cons "*function definition*" (copy-marker 74)) + (list + "wrap (def)" + (cons "*function definition*" (copy-marker 254)) + (cons "wrapped_f (def)" (copy-marker 294)))) + (list + "Baz (class)" + (cons "*class definition*" (copy-marker 519)) + (cons "a (def)" (copy-marker 539)) + (cons "b (def)" (copy-marker 570)) + (list + "Frob (class)" + (cons "*class definition*" (copy-marker 601)) + (cons "c (def)" (copy-marker 626))))) + (python-imenu-create-index))))) + +(ert-deftest python-imenu-create-index-2 () + (python-tests-with-temp-buffer + " +class Foo(object): + def foo(self): + def foo1(): + pass + + def foobar(self): + pass +" + (goto-char (point-max)) + (should (equal + (list + (list + "Foo (class)" + (cons "*class definition*" (copy-marker 2)) + (list + "foo (def)" + (cons "*function definition*" (copy-marker 21)) + (cons "foo1 (def)" (copy-marker 40))) + (cons "foobar (def)" (copy-marker 78)))) + (python-imenu-create-index))))) + +(ert-deftest python-imenu-create-index-3 () + (python-tests-with-temp-buffer + " +class Foo(object): + def foo(self): + def foo1(): + pass + def foo2(): + pass +" + (goto-char (point-max)) + (should (equal + (list + (list + "Foo (class)" + (cons "*class definition*" (copy-marker 2)) + (list + "foo (def)" + (cons "*function definition*" (copy-marker 21)) + (cons "foo1 (def)" (copy-marker 40)) + (cons "foo2 (def)" (copy-marker 77))))) + (python-imenu-create-index))))) + +(ert-deftest python-imenu-create-index-4 () + (python-tests-with-temp-buffer + " +class Foo(object): + class Bar(object): + def __init__(self): + pass + + def __str__(self): + pass + + def __init__(self): + pass +" + (goto-char (point-max)) + (should (equal + (list + (list + "Foo (class)" + (cons "*class definition*" (copy-marker 2)) + (list + "Bar (class)" + (cons "*class definition*" (copy-marker 21)) + (cons "__init__ (def)" (copy-marker 44)) + (cons "__str__ (def)" (copy-marker 90))) + (cons "__init__ (def)" (copy-marker 135)))) + (python-imenu-create-index))))) + +(ert-deftest python-imenu-create-flat-index-1 () + (python-tests-with-temp-buffer + " +class Foo(models.Model): + pass + + +class Bar(models.Model): + pass + + +def decorator(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decorator('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wrap(f): + print ('wrap') + def wrapped_f(*args): + print ('wrapped_f') + print ('Decorator arguments:', arg1, arg2, arg3) + f(*args) + print ('called f(*args)') + return wrapped_f + return wrap + + +class Baz(object): + + def a(self): + pass + + def b(self): + pass + + class Frob(object): + + def c(self): + pass +" + (goto-char (point-max)) + (should (equal + (list (cons "Foo" (copy-marker 2)) + (cons "Bar" (copy-marker 38)) + (cons "decorator" (copy-marker 74)) + (cons "decorator.wrap" (copy-marker 254)) + (cons "decorator.wrap.wrapped_f" (copy-marker 294)) + (cons "Baz" (copy-marker 519)) + (cons "Baz.a" (copy-marker 539)) + (cons "Baz.b" (copy-marker 570)) + (cons "Baz.Frob" (copy-marker 601)) + (cons "Baz.Frob.c" (copy-marker 626))) + (python-imenu-create-flat-index))))) + +(ert-deftest python-imenu-create-flat-index-2 () + (python-tests-with-temp-buffer + " +class Foo(object): + class Bar(object): + def __init__(self): + pass + + def __str__(self): + pass + + def __init__(self): + pass +" + (goto-char (point-max)) + (should (equal + (list + (cons "Foo" (copy-marker 2)) + (cons "Foo.Bar" (copy-marker 21)) + (cons "Foo.Bar.__init__" (copy-marker 44)) + (cons "Foo.Bar.__str__" (copy-marker 90)) + (cons "Foo.__init__" (copy-marker 135))) + (python-imenu-create-flat-index))))) + + +;;; Misc helpers + +(ert-deftest python-info-current-defun-1 () + (python-tests-with-temp-buffer + " +def foo(a, b): +" + (forward-line 1) + (should (string= "foo" (python-info-current-defun))) + (should (string= "def foo" (python-info-current-defun t))) + (forward-line 1) + (should (not (python-info-current-defun))) + (indent-for-tab-command) + (should (string= "foo" (python-info-current-defun))) + (should (string= "def foo" (python-info-current-defun t))))) + +(ert-deftest python-info-current-defun-2 () + (python-tests-with-temp-buffer + " +class C(object): + + def m(self): + if True: + return [i for i in range(3)] + else: + return [] + + def b(): + do_b() + + def a(): + do_a() + + def c(self): + do_c() +" + (forward-line 1) + (should (string= "C" (python-info-current-defun))) + (should (string= "class C" (python-info-current-defun t))) + (python-tests-look-at "return [i for ") + (should (string= "C.m" (python-info-current-defun))) + (should (string= "def C.m" (python-info-current-defun t))) + (python-tests-look-at "def b():") + (should (string= "C.m.b" (python-info-current-defun))) + (should (string= "def C.m.b" (python-info-current-defun t))) + (forward-line 2) + (indent-for-tab-command) + (python-indent-dedent-line-backspace 1) + (should (string= "C.m" (python-info-current-defun))) + (should (string= "def C.m" (python-info-current-defun t))) + (python-tests-look-at "def c(self):") + (forward-line -1) + (indent-for-tab-command) + (should (string= "C.m.a" (python-info-current-defun))) + (should (string= "def C.m.a" (python-info-current-defun t))) + (python-indent-dedent-line-backspace 1) + (should (string= "C.m" (python-info-current-defun))) + (should (string= "def C.m" (python-info-current-defun t))) + (python-indent-dedent-line-backspace 1) + (should (string= "C" (python-info-current-defun))) + (should (string= "class C" (python-info-current-defun t))) + (python-tests-look-at "def c(self):") + (should (string= "C.c" (python-info-current-defun))) + (should (string= "def C.c" (python-info-current-defun t))) + (python-tests-look-at "do_c()") + (should (string= "C.c" (python-info-current-defun))) + (should (string= "def C.c" (python-info-current-defun t))))) + +(ert-deftest python-info-current-defun-3 () + (python-tests-with-temp-buffer + " +def decoratorFunctionWithArguments(arg1, arg2, arg3): + '''print decorated function call data to stdout. + + Usage: + + @decoratorFunctionWithArguments('arg1', 'arg2') + def func(a, b, c=True): + pass + ''' + + def wwrap(f): + print 'Inside wwrap()' + def wrapped_f(*args): + print 'Inside wrapped_f()' + print 'Decorator arguments:', arg1, arg2, arg3 + f(*args) + print 'After f(*args)' + return wrapped_f + return wwrap +" + (python-tests-look-at "def wwrap(f):") + (forward-line -1) + (should (not (python-info-current-defun))) + (indent-for-tab-command 1) + (should (string= (python-info-current-defun) + "decoratorFunctionWithArguments")) + (should (string= (python-info-current-defun t) + "def decoratorFunctionWithArguments")) + (python-tests-look-at "def wrapped_f(*args):") + (should (string= (python-info-current-defun) + "decoratorFunctionWithArguments.wwrap.wrapped_f")) + (should (string= (python-info-current-defun t) + "def decoratorFunctionWithArguments.wwrap.wrapped_f")) + (python-tests-look-at "return wrapped_f") + (should (string= (python-info-current-defun) + "decoratorFunctionWithArguments.wwrap")) + (should (string= (python-info-current-defun t) + "def decoratorFunctionWithArguments.wwrap")) + (end-of-line 1) + (python-tests-look-at "return wwrap") + (should (string= (python-info-current-defun) + "decoratorFunctionWithArguments")) + (should (string= (python-info-current-defun t) + "def decoratorFunctionWithArguments")))) + +(ert-deftest python-info-current-symbol-1 () + (python-tests-with-temp-buffer + " +class C(object): + + def m(self): + self.c() + + def c(self): + print ('a') +" + (python-tests-look-at "self.c()") + (should (string= "self.c" (python-info-current-symbol))) + (should (string= "C.c" (python-info-current-symbol t))))) + +(ert-deftest python-info-current-symbol-2 () + (python-tests-with-temp-buffer + " +class C(object): + + class M(object): + + def a(self): + self.c() + + def c(self): + pass +" + (python-tests-look-at "self.c()") + (should (string= "self.c" (python-info-current-symbol))) + (should (string= "C.M.c" (python-info-current-symbol t))))) + +(ert-deftest python-info-current-symbol-3 () + "Keywords should not be considered symbols." + :expected-result :failed + (python-tests-with-temp-buffer + " +class C(object): + pass +" + ;; FIXME: keywords are not symbols. + (python-tests-look-at "class C") + (should (not (python-info-current-symbol))) + (should (not (python-info-current-symbol t))) + (python-tests-look-at "C(object)") + (should (string= "C" (python-info-current-symbol))) + (should (string= "class C" (python-info-current-symbol t))))) + +(ert-deftest python-info-statement-starts-block-p-1 () + (python-tests-with-temp-buffer + " +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (python-tests-look-at "def long_function_name") + (should (python-info-statement-starts-block-p)) + (python-tests-look-at "print (var_one)") + (python-util-forward-comment -1) + (should (python-info-statement-starts-block-p)))) + +(ert-deftest python-info-statement-starts-block-p-2 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError('sorry, you lose') +" + (python-tests-look-at "if width == 0 and") + (should (python-info-statement-starts-block-p)) + (python-tests-look-at "raise ValueError(") + (python-util-forward-comment -1) + (should (python-info-statement-starts-block-p)))) + +(ert-deftest python-info-statement-ends-block-p-1 () + (python-tests-with-temp-buffer + " +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (python-tests-look-at "print (var_one)") + (should (python-info-statement-ends-block-p)))) + +(ert-deftest python-info-statement-ends-block-p-2 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "raise ValueError(") + (should (python-info-statement-ends-block-p)))) + +(ert-deftest python-info-beginning-of-statement-p-1 () + (python-tests-with-temp-buffer + " +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (python-tests-look-at "def long_function_name") + (should (python-info-beginning-of-statement-p)) + (forward-char 10) + (should (not (python-info-beginning-of-statement-p))) + (python-tests-look-at "print (var_one)") + (should (python-info-beginning-of-statement-p)) + (goto-char (line-beginning-position)) + (should (not (python-info-beginning-of-statement-p))))) + +(ert-deftest python-info-beginning-of-statement-p-2 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "if width == 0 and") + (should (python-info-beginning-of-statement-p)) + (forward-char 10) + (should (not (python-info-beginning-of-statement-p))) + (python-tests-look-at "raise ValueError(") + (should (python-info-beginning-of-statement-p)) + (goto-char (line-beginning-position)) + (should (not (python-info-beginning-of-statement-p))))) + +(ert-deftest python-info-end-of-statement-p-1 () + (python-tests-with-temp-buffer + " +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (python-tests-look-at "def long_function_name") + (should (not (python-info-end-of-statement-p))) + (end-of-line) + (should (not (python-info-end-of-statement-p))) + (python-tests-look-at "print (var_one)") + (python-util-forward-comment -1) + (should (python-info-end-of-statement-p)) + (python-tests-look-at "print (var_one)") + (should (not (python-info-end-of-statement-p))) + (end-of-line) + (should (python-info-end-of-statement-p)))) + +(ert-deftest python-info-end-of-statement-p-2 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "if width == 0 and") + (should (not (python-info-end-of-statement-p))) + (end-of-line) + (should (not (python-info-end-of-statement-p))) + (python-tests-look-at "raise ValueError(") + (python-util-forward-comment -1) + (should (python-info-end-of-statement-p)) + (python-tests-look-at "raise ValueError(") + (should (not (python-info-end-of-statement-p))) + (end-of-line) + (should (not (python-info-end-of-statement-p))) + (goto-char (point-max)) + (python-util-forward-comment -1) + (should (python-info-end-of-statement-p)))) + +(ert-deftest python-info-beginning-of-block-p-1 () + (python-tests-with-temp-buffer + " +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (python-tests-look-at "def long_function_name") + (should (python-info-beginning-of-block-p)) + (python-tests-look-at "var_one, var_two, var_three,") + (should (not (python-info-beginning-of-block-p))) + (python-tests-look-at "print (var_one)") + (should (not (python-info-beginning-of-block-p))))) + +(ert-deftest python-info-beginning-of-block-p-2 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "if width == 0 and") + (should (python-info-beginning-of-block-p)) + (python-tests-look-at "color == 'red' and emphasis") + (should (not (python-info-beginning-of-block-p))) + (python-tests-look-at "raise ValueError(") + (should (not (python-info-beginning-of-block-p))))) + +(ert-deftest python-info-end-of-block-p-1 () + (python-tests-with-temp-buffer + " +def long_function_name( + var_one, var_two, var_three, + var_four): + print (var_one) +" + (python-tests-look-at "def long_function_name") + (should (not (python-info-end-of-block-p))) + (python-tests-look-at "var_one, var_two, var_three,") + (should (not (python-info-end-of-block-p))) + (python-tests-look-at "var_four):") + (end-of-line) + (should (not (python-info-end-of-block-p))) + (python-tests-look-at "print (var_one)") + (should (not (python-info-end-of-block-p))) + (end-of-line 1) + (should (python-info-end-of-block-p)))) + +(ert-deftest python-info-end-of-block-p-2 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "if width == 0 and") + (should (not (python-info-end-of-block-p))) + (python-tests-look-at "color == 'red' and emphasis == 'strong' or") + (should (not (python-info-end-of-block-p))) + (python-tests-look-at "highlight > 100:") + (end-of-line) + (should (not (python-info-end-of-block-p))) + (python-tests-look-at "raise ValueError(") + (should (not (python-info-end-of-block-p))) + (end-of-line 1) + (should (not (python-info-end-of-block-p))) + (goto-char (point-max)) + (python-util-forward-comment -1) + (should (python-info-end-of-block-p)))) + +(ert-deftest python-info-dedenter-opening-block-position-1 () + (python-tests-with-temp-buffer + " +if request.user.is_authenticated(): + try: + profile = request.user.get_profile() + except Profile.DoesNotExist: + profile = Profile.objects.create(user=request.user) + else: + if profile.stats: + profile.recalculate_stats() + else: + profile.clear_stats() + finally: + profile.views += 1 + profile.save() +" + (python-tests-look-at "try:") + (should (not (python-info-dedenter-opening-block-position))) + (python-tests-look-at "except Profile.DoesNotExist:") + (should (= (python-tests-look-at "try:" -1 t) + (python-info-dedenter-opening-block-position))) + (python-tests-look-at "else:") + (should (= (python-tests-look-at "except Profile.DoesNotExist:" -1 t) + (python-info-dedenter-opening-block-position))) + (python-tests-look-at "if profile.stats:") + (should (not (python-info-dedenter-opening-block-position))) + (python-tests-look-at "else:") + (should (= (python-tests-look-at "if profile.stats:" -1 t) + (python-info-dedenter-opening-block-position))) + (python-tests-look-at "finally:") + (should (= (python-tests-look-at "else:" -2 t) + (python-info-dedenter-opening-block-position))))) + +(ert-deftest python-info-dedenter-opening-block-position-2 () + (python-tests-with-temp-buffer + " +if request.user.is_authenticated(): + profile = Profile.objects.get_or_create(user=request.user) + if profile.stats: + profile.recalculate_stats() + +data = { + 'else': 'do it' +} + 'else' +" + (python-tests-look-at "'else': 'do it'") + (should (not (python-info-dedenter-opening-block-position))) + (python-tests-look-at "'else'") + (should (not (python-info-dedenter-opening-block-position))))) + +(ert-deftest python-info-dedenter-opening-block-position-3 () + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + except IOError: + msg = 'Error saving to disk' + message(msg) + logger.exception(msg) + except Exception: + if hide_details: + logger.exception('Unhandled exception') + else + finally: + data.free() +" + (python-tests-look-at "try:") + (should (not (python-info-dedenter-opening-block-position))) + + (python-tests-look-at "except IOError:") + (should (= (python-tests-look-at "try:" -1 t) + (python-info-dedenter-opening-block-position))) + + (python-tests-look-at "except Exception:") + (should (= (python-tests-look-at "except IOError:" -1 t) + (python-info-dedenter-opening-block-position))) + + (python-tests-look-at "if hide_details:") + (should (not (python-info-dedenter-opening-block-position))) + + ;; check indentation modifies the detected opening block + (python-tests-look-at "else") + (should (= (python-tests-look-at "if hide_details:" -1 t) + (python-info-dedenter-opening-block-position))) + + (indent-line-to 8) + (should (= (python-tests-look-at "if hide_details:" -1 t) + (python-info-dedenter-opening-block-position))) + + (indent-line-to 4) + (should (= (python-tests-look-at "except Exception:" -1 t) + (python-info-dedenter-opening-block-position))) + + (indent-line-to 0) + (should (= (python-tests-look-at "if save:" -1 t) + (python-info-dedenter-opening-block-position))))) + +(ert-deftest python-info-dedenter-opening-block-positions-1 () + (python-tests-with-temp-buffer + " +if save: + try: + write_to_disk(data) + except IOError: + msg = 'Error saving to disk' + message(msg) + logger.exception(msg) + except Exception: + if hide_details: + logger.exception('Unhandled exception') + else + finally: + data.free() +" + (python-tests-look-at "try:") + (should (not (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "except IOError:") + (should + (equal (list + (python-tests-look-at "try:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "except Exception:") + (should + (equal (list + (python-tests-look-at "except IOError:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "if hide_details:") + (should (not (python-info-dedenter-opening-block-positions))) + + ;; check indentation does not modify the detected opening blocks + (python-tests-look-at "else") + (should + (equal (list + (python-tests-look-at "if hide_details:" -1 t) + (python-tests-look-at "except Exception:" -1 t) + (python-tests-look-at "if save:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (indent-line-to 8) + (should + (equal (list + (python-tests-look-at "if hide_details:" -1 t) + (python-tests-look-at "except Exception:" -1 t) + (python-tests-look-at "if save:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (indent-line-to 4) + (should + (equal (list + (python-tests-look-at "if hide_details:" -1 t) + (python-tests-look-at "except Exception:" -1 t) + (python-tests-look-at "if save:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (indent-line-to 0) + (should + (equal (list + (python-tests-look-at "if hide_details:" -1 t) + (python-tests-look-at "except Exception:" -1 t) + (python-tests-look-at "if save:" -1 t)) + (python-info-dedenter-opening-block-positions))))) + +(ert-deftest python-info-dedenter-opening-block-positions-2 () + "Test detection of opening blocks for elif." + (python-tests-with-temp-buffer + " +if var: + if var2: + something() + elif var3: + something_else() + elif +" + (python-tests-look-at "elif var3:") + (should + (equal (list + (python-tests-look-at "if var2:" -1 t) + (python-tests-look-at "if var:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "elif\n") + (should + (equal (list + (python-tests-look-at "elif var3:" -1 t) + (python-tests-look-at "if var:" -1 t)) + (python-info-dedenter-opening-block-positions))))) + +(ert-deftest python-info-dedenter-opening-block-positions-3 () + "Test detection of opening blocks for else." + (python-tests-with-temp-buffer + " +try: + something() +except: + if var: + if var2: + something() + elif var3: + something_else() + else + +if var4: + while var5: + var4.pop() + else + + for value in var6: + if value > 0: + print value + else +" + (python-tests-look-at "else\n") + (should + (equal (list + (python-tests-look-at "elif var3:" -1 t) + (python-tests-look-at "if var:" -1 t) + (python-tests-look-at "except:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "else\n") + (should + (equal (list + (python-tests-look-at "while var5:" -1 t) + (python-tests-look-at "if var4:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "else\n") + (should + (equal (list + (python-tests-look-at "if value > 0:" -1 t) + (python-tests-look-at "for value in var6:" -1 t) + (python-tests-look-at "if var4:" -1 t)) + (python-info-dedenter-opening-block-positions))))) + +(ert-deftest python-info-dedenter-opening-block-positions-4 () + "Test detection of opening blocks for except." + (python-tests-with-temp-buffer + " +try: + something() +except ValueError: + something_else() + except +" + (python-tests-look-at "except ValueError:") + (should + (equal (list (python-tests-look-at "try:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "except\n") + (should + (equal (list (python-tests-look-at "except ValueError:" -1 t)) + (python-info-dedenter-opening-block-positions))))) + +(ert-deftest python-info-dedenter-opening-block-positions-5 () + "Test detection of opening blocks for finally." + (python-tests-with-temp-buffer + " +try: + something() + finally + +try: + something_else() +except: + logger.exception('something went wrong') + finally + +try: + something_else_else() +except Exception: + logger.exception('something else went wrong') +else: + print ('all good') + finally +" + (python-tests-look-at "finally\n") + (should + (equal (list (python-tests-look-at "try:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "finally\n") + (should + (equal (list (python-tests-look-at "except:" -1 t)) + (python-info-dedenter-opening-block-positions))) + + (python-tests-look-at "finally\n") + (should + (equal (list (python-tests-look-at "else:" -1 t)) + (python-info-dedenter-opening-block-positions))))) + +(ert-deftest python-info-dedenter-opening-block-message-1 () + "Test dedenters inside strings are ignored." + (python-tests-with-temp-buffer + "''' +try: + something() +except: + logger.exception('something went wrong') +''' +" + (python-tests-look-at "except\n") + (should (not (python-info-dedenter-opening-block-message))))) + +(ert-deftest python-info-dedenter-opening-block-message-2 () + "Test except keyword." + (python-tests-with-temp-buffer + " +try: + something() +except: + logger.exception('something went wrong') +" + (python-tests-look-at "except:") + (should (string= + "Closes try:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))) + (end-of-line) + (should (string= + "Closes try:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))))) + +(ert-deftest python-info-dedenter-opening-block-message-3 () + "Test else keyword." + (python-tests-with-temp-buffer + " +try: + something() +except: + logger.exception('something went wrong') +else: + logger.debug('all good') +" + (python-tests-look-at "else:") + (should (string= + "Closes except:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))) + (end-of-line) + (should (string= + "Closes except:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))))) + +(ert-deftest python-info-dedenter-opening-block-message-4 () + "Test finally keyword." + (python-tests-with-temp-buffer + " +try: + something() +except: + logger.exception('something went wrong') +else: + logger.debug('all good') +finally: + clean() +" + (python-tests-look-at "finally:") + (should (string= + "Closes else:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))) + (end-of-line) + (should (string= + "Closes else:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))))) + +(ert-deftest python-info-dedenter-opening-block-message-5 () + "Test elif keyword." + (python-tests-with-temp-buffer + " +if a: + something() +elif b: +" + (python-tests-look-at "elif b:") + (should (string= + "Closes if a:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))) + (end-of-line) + (should (string= + "Closes if a:" + (substring-no-properties + (python-info-dedenter-opening-block-message)))))) + + +(ert-deftest python-info-dedenter-statement-p-1 () + "Test dedenters inside strings are ignored." + (python-tests-with-temp-buffer + "''' +try: + something() +except: + logger.exception('something went wrong') +''' +" + (python-tests-look-at "except\n") + (should (not (python-info-dedenter-statement-p))))) + +(ert-deftest python-info-dedenter-statement-p-2 () + "Test except keyword." + (python-tests-with-temp-buffer + " +try: + something() +except: + logger.exception('something went wrong') +" + (python-tests-look-at "except:") + (should (= (point) (python-info-dedenter-statement-p))) + (end-of-line) + (should (= (save-excursion + (back-to-indentation) + (point)) + (python-info-dedenter-statement-p))))) + +(ert-deftest python-info-dedenter-statement-p-3 () + "Test else keyword." + (python-tests-with-temp-buffer + " +try: + something() +except: + logger.exception('something went wrong') +else: + logger.debug('all good') +" + (python-tests-look-at "else:") + (should (= (point) (python-info-dedenter-statement-p))) + (end-of-line) + (should (= (save-excursion + (back-to-indentation) + (point)) + (python-info-dedenter-statement-p))))) + +(ert-deftest python-info-dedenter-statement-p-4 () + "Test finally keyword." + (python-tests-with-temp-buffer + " +try: + something() +except: + logger.exception('something went wrong') +else: + logger.debug('all good') +finally: + clean() +" + (python-tests-look-at "finally:") + (should (= (point) (python-info-dedenter-statement-p))) + (end-of-line) + (should (= (save-excursion + (back-to-indentation) + (point)) + (python-info-dedenter-statement-p))))) + +(ert-deftest python-info-dedenter-statement-p-5 () + "Test elif keyword." + (python-tests-with-temp-buffer + " +if a: + something() +elif b: +" + (python-tests-look-at "elif b:") + (should (= (point) (python-info-dedenter-statement-p))) + (end-of-line) + (should (= (save-excursion + (back-to-indentation) + (point)) + (python-info-dedenter-statement-p))))) + +(ert-deftest python-info-line-ends-backslash-p-1 () + (python-tests-with-temp-buffer + " +objects = Thing.objects.all() \\\\ + .filter( + type='toy', + status='bought' + ) \\\\ + .aggregate( + Sum('amount') + ) \\\\ + .values_list() +" + (should (python-info-line-ends-backslash-p 2)) ; .filter(... + (should (python-info-line-ends-backslash-p 3)) + (should (python-info-line-ends-backslash-p 4)) + (should (python-info-line-ends-backslash-p 5)) + (should (python-info-line-ends-backslash-p 6)) ; ) \... + (should (python-info-line-ends-backslash-p 7)) + (should (python-info-line-ends-backslash-p 8)) + (should (python-info-line-ends-backslash-p 9)) + (should (not (python-info-line-ends-backslash-p 10))))) ; .values_list()... + +(ert-deftest python-info-beginning-of-backslash-1 () + (python-tests-with-temp-buffer + " +objects = Thing.objects.all() \\\\ + .filter( + type='toy', + status='bought' + ) \\\\ + .aggregate( + Sum('amount') + ) \\\\ + .values_list() +" + (let ((first 2) + (second (python-tests-look-at ".filter(")) + (third (python-tests-look-at ".aggregate("))) + (should (= first (python-info-beginning-of-backslash 2))) + (should (= second (python-info-beginning-of-backslash 3))) + (should (= second (python-info-beginning-of-backslash 4))) + (should (= second (python-info-beginning-of-backslash 5))) + (should (= second (python-info-beginning-of-backslash 6))) + (should (= third (python-info-beginning-of-backslash 7))) + (should (= third (python-info-beginning-of-backslash 8))) + (should (= third (python-info-beginning-of-backslash 9))) + (should (not (python-info-beginning-of-backslash 10)))))) + +(ert-deftest python-info-continuation-line-p-1 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "if width == 0 and height == 0 and") + (should (not (python-info-continuation-line-p))) + (python-tests-look-at "color == 'red' and emphasis == 'strong' or") + (should (python-info-continuation-line-p)) + (python-tests-look-at "highlight > 100:") + (should (python-info-continuation-line-p)) + (python-tests-look-at "raise ValueError(") + (should (not (python-info-continuation-line-p))) + (python-tests-look-at "'sorry, you lose'") + (should (python-info-continuation-line-p)) + (forward-line 1) + (should (python-info-continuation-line-p)) + (python-tests-look-at ")") + (should (python-info-continuation-line-p)) + (forward-line 1) + (should (not (python-info-continuation-line-p))))) + +(ert-deftest python-info-block-continuation-line-p-1 () + (python-tests-with-temp-buffer + " +if width == 0 and height == 0 and \\\\ + color == 'red' and emphasis == 'strong' or \\\\ + highlight > 100: + raise ValueError( +'sorry, you lose' + +) +" + (python-tests-look-at "if width == 0 and") + (should (not (python-info-block-continuation-line-p))) + (python-tests-look-at "color == 'red' and emphasis == 'strong' or") + (should (= (python-info-block-continuation-line-p) + (python-tests-look-at "if width == 0 and" -1 t))) + (python-tests-look-at "highlight > 100:") + (should (not (python-info-block-continuation-line-p))))) + +(ert-deftest python-info-block-continuation-line-p-2 () + (python-tests-with-temp-buffer + " +def foo(a, + b, + c): + pass +" + (python-tests-look-at "def foo(a,") + (should (not (python-info-block-continuation-line-p))) + (python-tests-look-at "b,") + (should (= (python-info-block-continuation-line-p) + (python-tests-look-at "def foo(a," -1 t))) + (python-tests-look-at "c):") + (should (not (python-info-block-continuation-line-p))))) + +(ert-deftest python-info-assignment-statement-p-1 () + (python-tests-with-temp-buffer + " +data = foo(), bar() \\\\ + baz(), 4 \\\\ + 5, 6 +" + (python-tests-look-at "data = foo(), bar()") + (should (python-info-assignment-statement-p)) + (should (python-info-assignment-statement-p t)) + (python-tests-look-at "baz(), 4") + (should (python-info-assignment-statement-p)) + (should (not (python-info-assignment-statement-p t))) + (python-tests-look-at "5, 6") + (should (python-info-assignment-statement-p)) + (should (not (python-info-assignment-statement-p t))))) + +(ert-deftest python-info-assignment-statement-p-2 () + (python-tests-with-temp-buffer + " +data = (foo(), bar() + baz(), 4 + 5, 6) +" + (python-tests-look-at "data = (foo(), bar()") + (should (python-info-assignment-statement-p)) + (should (python-info-assignment-statement-p t)) + (python-tests-look-at "baz(), 4") + (should (python-info-assignment-statement-p)) + (should (not (python-info-assignment-statement-p t))) + (python-tests-look-at "5, 6)") + (should (python-info-assignment-statement-p)) + (should (not (python-info-assignment-statement-p t))))) + +(ert-deftest python-info-assignment-statement-p-3 () + (python-tests-with-temp-buffer + " +data '=' 42 +" + (python-tests-look-at "data '=' 42") + (should (not (python-info-assignment-statement-p))) + (should (not (python-info-assignment-statement-p t))))) + +(ert-deftest python-info-assignment-continuation-line-p-1 () + (python-tests-with-temp-buffer + " +data = foo(), bar() \\\\ + baz(), 4 \\\\ + 5, 6 +" + (python-tests-look-at "data = foo(), bar()") + (should (not (python-info-assignment-continuation-line-p))) + (python-tests-look-at "baz(), 4") + (should (= (python-info-assignment-continuation-line-p) + (python-tests-look-at "foo()," -1 t))) + (python-tests-look-at "5, 6") + (should (not (python-info-assignment-continuation-line-p))))) + +(ert-deftest python-info-assignment-continuation-line-p-2 () + (python-tests-with-temp-buffer + " +data = (foo(), bar() + baz(), 4 + 5, 6) +" + (python-tests-look-at "data = (foo(), bar()") + (should (not (python-info-assignment-continuation-line-p))) + (python-tests-look-at "baz(), 4") + (should (= (python-info-assignment-continuation-line-p) + (python-tests-look-at "(foo()," -1 t))) + (python-tests-look-at "5, 6)") + (should (not (python-info-assignment-continuation-line-p))))) + +(ert-deftest python-info-looking-at-beginning-of-defun-1 () + (python-tests-with-temp-buffer + " +def decorat0r(deff): + '''decorates stuff. + + @decorat0r + def foo(arg): + ... + ''' + def wrap(): + deff() + return wwrap +" + (python-tests-look-at "def decorat0r(deff):") + (should (python-info-looking-at-beginning-of-defun)) + (python-tests-look-at "def foo(arg):") + (should (not (python-info-looking-at-beginning-of-defun))) + (python-tests-look-at "def wrap():") + (should (python-info-looking-at-beginning-of-defun)) + (python-tests-look-at "deff()") + (should (not (python-info-looking-at-beginning-of-defun))))) + +(ert-deftest python-info-current-line-comment-p-1 () + (python-tests-with-temp-buffer + " +# this is a comment +foo = True # another comment +'#this is a string' +if foo: + # more comments + print ('bar') # print bar +" + (python-tests-look-at "# this is a comment") + (should (python-info-current-line-comment-p)) + (python-tests-look-at "foo = True # another comment") + (should (not (python-info-current-line-comment-p))) + (python-tests-look-at "'#this is a string'") + (should (not (python-info-current-line-comment-p))) + (python-tests-look-at "# more comments") + (should (python-info-current-line-comment-p)) + (python-tests-look-at "print ('bar') # print bar") + (should (not (python-info-current-line-comment-p))))) + +(ert-deftest python-info-current-line-empty-p () + (python-tests-with-temp-buffer + " +# this is a comment + +foo = True # another comment +" + (should (python-info-current-line-empty-p)) + (python-tests-look-at "# this is a comment") + (should (not (python-info-current-line-empty-p))) + (forward-line 1) + (should (python-info-current-line-empty-p)))) + +(ert-deftest python-info-docstring-p-1 () + "Test module docstring detection." + (python-tests-with-temp-buffer + "# -*- coding: utf-8 -*- +#!/usr/bin/python + +''' +Module Docstring Django style. +''' +u'''Additional module docstring.''' +'''Not a module docstring.''' +" + (python-tests-look-at "Module Docstring Django style.") + (should (python-info-docstring-p)) + (python-tests-look-at "u'''Additional module docstring.'''") + (should (python-info-docstring-p)) + (python-tests-look-at "'''Not a module docstring.'''") + (should (not (python-info-docstring-p))))) + +(ert-deftest python-info-docstring-p-2 () + "Test variable docstring detection." + (python-tests-with-temp-buffer + " +variable = 42 +U'''Variable docstring.''' +'''Additional variable docstring.''' +'''Not a variable docstring.''' +" + (python-tests-look-at "Variable docstring.") + (should (python-info-docstring-p)) + (python-tests-look-at "u'''Additional variable docstring.'''") + (should (python-info-docstring-p)) + (python-tests-look-at "'''Not a variable docstring.'''") + (should (not (python-info-docstring-p))))) + +(ert-deftest python-info-docstring-p-3 () + "Test function docstring detection." + (python-tests-with-temp-buffer + " +def func(a, b): + r''' + Function docstring. + + onetwo style. + ''' + R'''Additional function docstring.''' + '''Not a function docstring.''' + return a + b +" + (python-tests-look-at "Function docstring.") + (should (python-info-docstring-p)) + (python-tests-look-at "R'''Additional function docstring.'''") + (should (python-info-docstring-p)) + (python-tests-look-at "'''Not a function docstring.'''") + (should (not (python-info-docstring-p))))) + +(ert-deftest python-info-docstring-p-4 () + "Test class docstring detection." + (python-tests-with-temp-buffer + " +class Class: + ur''' + Class docstring. + + symmetric style. + ''' + uR''' + Additional class docstring. + ''' + '''Not a class docstring.''' + pass +" + (python-tests-look-at "Class docstring.") + (should (python-info-docstring-p)) + (python-tests-look-at "uR'''") ;; Additional class docstring + (should (python-info-docstring-p)) + (python-tests-look-at "'''Not a class docstring.'''") + (should (not (python-info-docstring-p))))) + +(ert-deftest python-info-docstring-p-5 () + "Test class attribute docstring detection." + (python-tests-with-temp-buffer + " +class Class: + attribute = 42 + Ur''' + Class attribute docstring. + + pep-257 style. + + ''' + UR''' + Additional class attribute docstring. + ''' + '''Not a class attribute docstring.''' + pass +" + (python-tests-look-at "Class attribute docstring.") + (should (python-info-docstring-p)) + (python-tests-look-at "UR'''") ;; Additional class attr docstring + (should (python-info-docstring-p)) + (python-tests-look-at "'''Not a class attribute docstring.'''") + (should (not (python-info-docstring-p))))) + +(ert-deftest python-info-docstring-p-6 () + "Test class method docstring detection." + (python-tests-with-temp-buffer + " +class Class: + + def __init__(self, a, b): + self.a = a + self.b = b + + def __call__(self): + '''Method docstring. + + pep-257-nn style. + ''' + '''Additional method docstring.''' + '''Not a method docstring.''' + return self.a + self.b +" + (python-tests-look-at "Method docstring.") + (should (python-info-docstring-p)) + (python-tests-look-at "'''Additional method docstring.'''") + (should (python-info-docstring-p)) + (python-tests-look-at "'''Not a method docstring.'''") + (should (not (python-info-docstring-p))))) + +(ert-deftest python-info-encoding-from-cookie-1 () + "Should detect it on first line." + (python-tests-with-temp-buffer + "# coding=latin-1 + +foo = True # another comment +" + (should (eq (python-info-encoding-from-cookie) 'latin-1)))) + +(ert-deftest python-info-encoding-from-cookie-2 () + "Should detect it on second line." + (python-tests-with-temp-buffer + " +# coding=latin-1 + +foo = True # another comment +" + (should (eq (python-info-encoding-from-cookie) 'latin-1)))) + +(ert-deftest python-info-encoding-from-cookie-3 () + "Should not be detected on third line (and following ones)." + (python-tests-with-temp-buffer + " + +# coding=latin-1 +foo = True # another comment +" + (should (not (python-info-encoding-from-cookie))))) + +(ert-deftest python-info-encoding-from-cookie-4 () + "Should detect Emacs style." + (python-tests-with-temp-buffer + "# -*- coding: latin-1 -*- + +foo = True # another comment" + (should (eq (python-info-encoding-from-cookie) 'latin-1)))) + +(ert-deftest python-info-encoding-from-cookie-5 () + "Should detect Vim style." + (python-tests-with-temp-buffer + "# vim: set fileencoding=latin-1 : + +foo = True # another comment" + (should (eq (python-info-encoding-from-cookie) 'latin-1)))) + +(ert-deftest python-info-encoding-from-cookie-6 () + "First cookie wins." + (python-tests-with-temp-buffer + "# -*- coding: iso-8859-1 -*- +# vim: set fileencoding=latin-1 : + +foo = True # another comment" + (should (eq (python-info-encoding-from-cookie) 'iso-8859-1)))) + +(ert-deftest python-info-encoding-from-cookie-7 () + "First cookie wins." + (python-tests-with-temp-buffer + "# vim: set fileencoding=latin-1 : +# -*- coding: iso-8859-1 -*- + +foo = True # another comment" + (should (eq (python-info-encoding-from-cookie) 'latin-1)))) + +(ert-deftest python-info-encoding-1 () + "Should return the detected encoding from cookie." + (python-tests-with-temp-buffer + "# vim: set fileencoding=latin-1 : + +foo = True # another comment" + (should (eq (python-info-encoding) 'latin-1)))) + +(ert-deftest python-info-encoding-2 () + "Should default to utf-8." + (python-tests-with-temp-buffer + "# No encoding for you + +foo = True # another comment" + (should (eq (python-info-encoding) 'utf-8)))) + + +;;; Utility functions + +(ert-deftest python-util-goto-line-1 () + (python-tests-with-temp-buffer + (concat + "# a comment +# another comment +def foo(a, b, c): + pass" (make-string 20 ?\n)) + (python-util-goto-line 10) + (should (= (line-number-at-pos) 10)) + (python-util-goto-line 20) + (should (= (line-number-at-pos) 20)))) + +(ert-deftest python-util-clone-local-variables-1 () + (let ((buffer (generate-new-buffer + "python-util-clone-local-variables-1")) + (varcons + '((python-fill-docstring-style . django) + (python-shell-interpreter . "python") + (python-shell-interpreter-args . "manage.py shell") + (python-shell-prompt-regexp . "In \\[[0-9]+\\]: ") + (python-shell-prompt-output-regexp . "Out\\[[0-9]+\\]: ") + (python-shell-extra-pythonpaths "/home/user/pylib/") + (python-shell-completion-setup-code + . "from IPython.core.completerlib import module_completion") + (python-shell-completion-string-code + . "';'.join(get_ipython().Completer.all_completions('''%s'''))\n") + (python-shell-virtualenv-root + . "/home/user/.virtualenvs/project")))) + (with-current-buffer buffer + (kill-all-local-variables) + (dolist (ccons varcons) + (set (make-local-variable (car ccons)) (cdr ccons)))) + (python-tests-with-temp-buffer + "" + (python-util-clone-local-variables buffer) + (dolist (ccons varcons) + (should + (equal (symbol-value (car ccons)) (cdr ccons))))) + (kill-buffer buffer))) + +(ert-deftest python-util-strip-string-1 () + (should (string= (python-util-strip-string "\t\r\n str") "str")) + (should (string= (python-util-strip-string "str \n\r") "str")) + (should (string= (python-util-strip-string "\t\r\n str \n\r ") "str")) + (should + (string= (python-util-strip-string "\n str \nin \tg \n\r") "str \nin \tg")) + (should (string= (python-util-strip-string "\n \t \n\r ") "")) + (should (string= (python-util-strip-string "") ""))) + +(ert-deftest python-util-forward-comment-1 () + (python-tests-with-temp-buffer + (concat + "# a comment +# another comment + # bad indented comment +# more comments" (make-string 9999 ?\n)) + (python-util-forward-comment 1) + (should (= (point) (point-max))) + (python-util-forward-comment -1) + (should (= (point) (point-min))))) + +(ert-deftest python-util-valid-regexp-p-1 () + (should (python-util-valid-regexp-p "")) + (should (python-util-valid-regexp-p python-shell-prompt-regexp)) + (should (not (python-util-valid-regexp-p "\\(")))) + + +;;; Electricity + +(ert-deftest python-parens-electric-indent-1 () + (let ((eim electric-indent-mode)) + (unwind-protect + (progn + (python-tests-with-temp-buffer + " +from django.conf.urls import patterns, include, url + +from django.contrib import admin + +from myapp import views + + +urlpatterns = patterns('', + url(r'^$', views.index +) +" + (electric-indent-mode 1) + (python-tests-look-at "views.index") + (end-of-line) + + ;; Inserting commas within the same line should leave + ;; indentation unchanged. + (python-tests-self-insert ",") + (should (= (current-indentation) 4)) + + ;; As well as any other input happening within the same + ;; set of parens. + (python-tests-self-insert " name='index')") + (should (= (current-indentation) 4)) + + ;; But a comma outside it, should trigger indentation. + (python-tests-self-insert ",") + (should (= (current-indentation) 23)) + + ;; Newline indents to the first argument column + (python-tests-self-insert "\n") + (should (= (current-indentation) 23)) + + ;; All this input must not change indentation + (indent-line-to 4) + (python-tests-self-insert "url(r'^/login$', views.login)") + (should (= (current-indentation) 4)) + + ;; But this comma does + (python-tests-self-insert ",") + (should (= (current-indentation) 23)))) + (or eim (electric-indent-mode -1))))) + +(ert-deftest python-triple-quote-pairing () + (let ((epm electric-pair-mode)) + (unwind-protect + (progn + (python-tests-with-temp-buffer + "\"\"\n" + (or epm (electric-pair-mode 1)) + (goto-char (1- (point-max))) + (python-tests-self-insert ?\") + (should (string= (buffer-string) + "\"\"\"\"\"\"\n")) + (should (= (point) 4))) + (python-tests-with-temp-buffer + "\n" + (python-tests-self-insert (list ?\" ?\" ?\")) + (should (string= (buffer-string) + "\"\"\"\"\"\"\n")) + (should (= (point) 4))) + (python-tests-with-temp-buffer + "\"\n\"\"\n" + (goto-char (1- (point-max))) + (python-tests-self-insert ?\") + (should (= (point) (1- (point-max)))) + (should (string= (buffer-string) + "\"\n\"\"\"\n")))) + (or epm (electric-pair-mode -1))))) + + +;;; Hideshow support + +(ert-deftest python-hideshow-hide-levels-1 () + "Should hide all methods when called after class start." + (let ((enabled hs-minor-mode)) + (unwind-protect + (progn + (python-tests-with-temp-buffer + " +class SomeClass: + + def __init__(self, arg, kwarg=1): + self.arg = arg + self.kwarg = kwarg + + def filter(self, nums): + def fn(item): + return item in [self.arg, self.kwarg] + return filter(fn, nums) + + def __str__(self): + return '%s-%s' % (self.arg, self.kwarg) +" + (hs-minor-mode 1) + (python-tests-look-at "class SomeClass:") + (forward-line) + (hs-hide-level 1) + (should + (string= + (python-tests-visible-string) + " +class SomeClass: + + def __init__(self, arg, kwarg=1): + def filter(self, nums): + def __str__(self):")))) + (or enabled (hs-minor-mode -1))))) + +(ert-deftest python-hideshow-hide-levels-2 () + "Should hide nested methods and parens at end of defun." + (let ((enabled hs-minor-mode)) + (unwind-protect + (progn + (python-tests-with-temp-buffer + " +class SomeClass: + + def __init__(self, arg, kwarg=1): + self.arg = arg + self.kwarg = kwarg + + def filter(self, nums): + def fn(item): + return item in [self.arg, self.kwarg] + return filter(fn, nums) + + def __str__(self): + return '%s-%s' % (self.arg, self.kwarg) +" + (hs-minor-mode 1) + (python-tests-look-at "def fn(item):") + (hs-hide-block) + (should + (string= + (python-tests-visible-string) + " +class SomeClass: + + def __init__(self, arg, kwarg=1): + self.arg = arg + self.kwarg = kwarg + + def filter(self, nums): + def fn(item): + return filter(fn, nums) + + def __str__(self): + return '%s-%s' % (self.arg, self.kwarg) +")))) + (or enabled (hs-minor-mode -1))))) + + + +(provide 'python-tests) + +;; Local Variables: +;; indent-tabs-mode: nil +;; End: + +;;; python-tests.el ends here diff --cc test/lisp/progmodes/ruby-mode-tests.el index 97f277bff41,00000000000..f04483f6d7c mode 100644,000000..100644 --- a/test/lisp/progmodes/ruby-mode-tests.el +++ b/test/lisp/progmodes/ruby-mode-tests.el @@@ -1,752 -1,0 +1,752 @@@ +;;; ruby-mode-tests.el --- Test suite for ruby-mode + - ;; Copyright (C) 2012-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2012-2017 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'ruby-mode) + +(defmacro ruby-with-temp-buffer (contents &rest body) + (declare (indent 1) (debug t)) + `(with-temp-buffer + (insert ,contents) + (ruby-mode) + ,@body)) + +(defun ruby-should-indent (content column) + "Assert indentation COLUMN on the last line of CONTENT." + (ruby-with-temp-buffer content + (indent-according-to-mode) + (should (= (current-indentation) column)))) + +(defun ruby-should-indent-buffer (expected content) + "Assert that CONTENT turns into EXPECTED after the buffer is re-indented. + +The whitespace before and including \"|\" on each line is removed." + (ruby-with-temp-buffer (ruby-test-string content) + (indent-region (point-min) (point-max)) + (should (string= (ruby-test-string expected) (buffer-string))))) + +(defun ruby-test-string (s &rest args) + (apply 'format (replace-regexp-in-string "^[ \t]*|" "" s) args)) + +(defun ruby-assert-state (content index value &optional point) + "Assert syntax state values at the end of CONTENT. + +VALUES-PLIST is a list with alternating index and value elements." + (ruby-with-temp-buffer content + (when point (goto-char point)) + (syntax-propertize (point)) + (should (eq (nth index + (parse-partial-sexp (point-min) (point))) + value)))) + +(defun ruby-assert-face (content pos face) + (ruby-with-temp-buffer content + (font-lock-ensure nil nil) + (should (eq face (get-text-property pos 'face))))) + +(ert-deftest ruby-indent-after-symbol-made-from-string-interpolation () + "It can indent the line after symbol made using string interpolation." + (ruby-should-indent "def foo(suffix)\n :\"bar#{suffix}\"\n" + ruby-indent-level)) + +(ert-deftest ruby-indent-after-js-style-symbol-with-block-beg-name () + "JS-style hash symbol can have keyword name." + (ruby-should-indent "link_to \"home\", home_path, class: \"foo\"\n" 0)) + +(ert-deftest ruby-discern-singleton-class-from-heredoc () + (ruby-assert-state "foo < 5 } + | .map { |str| str.downcase }" + "one.two.three + | .four + | + |my_array.select { |str| str.size > 5 } + | .map { |str| str.downcase }"))) + +(ert-deftest ruby-move-to-block-stops-at-indentation () + (ruby-with-temp-buffer "def f\nend" + (beginning-of-line) + (ruby-move-to-block -1) + (should (looking-at "^def")))) + +(ert-deftest ruby-toggle-block-to-do-end () + (ruby-with-temp-buffer "foo {|b|\n}" + (beginning-of-line) + (ruby-toggle-block) + (should (string= "foo do |b|\nend" (buffer-string))))) + +(ert-deftest ruby-toggle-block-to-brace () + (let ((pairs '((17 . "foo { |b| b + 2 }") + (16 . "foo { |b|\n b + 2\n}")))) + (dolist (pair pairs) + (with-temp-buffer + (let ((fill-column (car pair))) + (insert "foo do |b|\n b + 2\nend") + (ruby-mode) + (beginning-of-line) + (ruby-toggle-block) + (should (string= (cdr pair) (buffer-string)))))))) + +(ert-deftest ruby-toggle-block-to-multiline () + (ruby-with-temp-buffer "foo {|b| b + 1}" + (beginning-of-line) + (ruby-toggle-block) + (should (string= "foo do |b|\n b + 1\nend" (buffer-string))))) + +(ert-deftest ruby-toggle-block-with-interpolation () + (ruby-with-temp-buffer "foo do\n \"#{bar}\"\nend" + (beginning-of-line) + (ruby-toggle-block) + (should (string= "foo { \"#{bar}\" }" (buffer-string))))) + +(ert-deftest ruby-recognize-symbols-starting-with-at-character () + (ruby-assert-face ":@abc" 3 font-lock-constant-face)) + +(ert-deftest ruby-hash-character-not-interpolation () + (ruby-assert-face "\"This is #{interpolation}\"" 15 + font-lock-variable-name-face) + (ruby-assert-face "\"This is \\#{no interpolation} despite the #\"" + 15 font-lock-string-face) + (ruby-assert-face "\n#@comment, not ruby code" 5 font-lock-comment-face) + (ruby-assert-state "\n#@comment, not ruby code" 4 t) + (ruby-assert-face "# A comment cannot have #{an interpolation} in it" + 30 font-lock-comment-face) + (ruby-assert-face "# #{comment}\n \"#{interpolation}\"" 16 + font-lock-variable-name-face)) + +(ert-deftest ruby-interpolation-suppresses-quotes-inside () + (let ((s "\"
    • #{@files.join(\"
    • \")}
    \"")) + (ruby-assert-state s 8 nil) + (ruby-assert-face s 9 font-lock-string-face) + (ruby-assert-face s 10 font-lock-variable-name-face) + (ruby-assert-face s 41 font-lock-string-face))) + +(ert-deftest ruby-interpolation-suppresses-one-double-quote () + (let ((s "\"foo#{'\"'}\"")) + (ruby-assert-state s 8 nil) + (ruby-assert-face s 8 font-lock-variable-name-face) + (ruby-assert-face s 11 font-lock-string-face))) + +(ert-deftest ruby-interpolation-suppresses-one-backtick () + (let ((s "`as#{'`'}das`")) + (ruby-assert-state s 8 nil))) + +(ert-deftest ruby-interpolation-keeps-non-quote-syntax () + (let ((s "\"foo#{baz.tee}bar\"")) + (ruby-with-temp-buffer s + (goto-char (point-min)) + (ruby-mode) + (syntax-propertize (point-max)) + (search-forward "tee") + (should (string= (thing-at-point 'symbol) "tee"))))) + +(ert-deftest ruby-interpolation-inside-percent-literal () + (let ((s "%( #{boo} )")) + (ruby-assert-face s 1 font-lock-string-face) + (ruby-assert-face s 4 font-lock-variable-name-face) + (ruby-assert-face s 10 font-lock-string-face) + (ruby-assert-state s 8 nil))) + +(ert-deftest ruby-interpolation-inside-percent-literal-with-paren () + :expected-result :failed + (let ((s "%(^#{\")\"}^)")) + (ruby-assert-face s 3 font-lock-string-face) + (ruby-assert-face s 4 font-lock-variable-name-face) + (ruby-assert-face s 10 font-lock-string-face) + ;; It's confused by the closing paren in the middle. + (ruby-assert-state s 8 nil))) + +(ert-deftest ruby-interpolation-inside-another-interpolation () + :expected-result :failed + (let ((s "\"#{[a, b, c].map { |v| \"#{v}\" }.join}\"")) + (ruby-assert-face s 1 font-lock-string-face) + (ruby-assert-face s 2 font-lock-variable-name-face) + (ruby-assert-face s 38 font-lock-string-face) + (ruby-assert-state s 8 nil))) + +(ert-deftest ruby-interpolation-inside-double-quoted-percent-literals () + (ruby-assert-face "%Q{foo #@bar}" 8 font-lock-variable-name-face) + (ruby-assert-face "%W{foo #@bar}" 8 font-lock-variable-name-face) + (ruby-assert-face "%r{foo #@bar}" 8 font-lock-variable-name-face) + (ruby-assert-face "%x{foo #@bar}" 8 font-lock-variable-name-face)) + +(ert-deftest ruby-no-interpolation-in-single-quoted-literals () + (ruby-assert-face "'foo #@bar'" 7 font-lock-string-face) + (ruby-assert-face "%q{foo #@bar}" 8 font-lock-string-face) + (ruby-assert-face "%w{foo #@bar}" 8 font-lock-string-face) + (ruby-assert-face "%s{foo #@bar}" 8 font-lock-string-face)) + +(ert-deftest ruby-interpolation-after-dollar-sign () + (ruby-assert-face "\"$#{balance}\"" 2 'font-lock-string-face) + (ruby-assert-face "\"$#{balance}\"" 3 'font-lock-variable-name-face)) + +(ert-deftest ruby-no-unknown-percent-literals () + ;; No folding of case. + (ruby-assert-face "%S{foo}" 4 nil) + (ruby-assert-face "%R{foo}" 4 nil)) + +(ert-deftest ruby-no-nested-percent-literals () + (ruby-with-temp-buffer "a = %w[b %()]" + (syntax-propertize (point)) + (should (null (nth 8 (syntax-ppss)))) + (should (eq t (nth 3 (syntax-ppss (1- (point-max)))))) + (search-backward "[") + (should (eq t (nth 3 (syntax-ppss)))))) + +(ert-deftest ruby-add-log-current-method-examples () + (let ((pairs '(("foo" . "#foo") + ("C.foo" . ".foo") + ("self.foo" . ".foo")))) + (dolist (pair pairs) + (let ((name (car pair)) + (value (cdr pair))) + (ruby-with-temp-buffer (ruby-test-string + "module M + | class C + | def %s + | _ + | end + | end + |end" + name) + (search-backward "_") + (forward-line) + (should (string= (ruby-add-log-current-method) + (format "M::C%s" value)))))))) + +(ert-deftest ruby-add-log-current-method-outside-of-method () + (ruby-with-temp-buffer (ruby-test-string + "module M + | class C + | def foo + | end + | _ + | end + |end") + (search-backward "_") + (should (string= (ruby-add-log-current-method)"M::C")))) + +(ert-deftest ruby-add-log-current-method-in-singleton-class () + (ruby-with-temp-buffer (ruby-test-string + "class C + | class << self + | def foo + | _ + | end + | end + |end") + (search-backward "_") + (should (string= (ruby-add-log-current-method) "C.foo")))) + +(ert-deftest ruby-add-log-current-method-namespace-shorthand () + (ruby-with-temp-buffer (ruby-test-string + "class C::D + | def foo + | _ + | end + |end") + (search-backward "_") + (should (string= (ruby-add-log-current-method) "C::D#foo")))) + +(ert-deftest ruby-add-log-current-method-after-inner-class () + (ruby-with-temp-buffer (ruby-test-string + "module M + | class C + | class D + | end + | def foo + | _ + | end + | end + |end") + (search-backward "_") + (should (string= (ruby-add-log-current-method) "M::C#foo")))) + +(defvar ruby-block-test-example + (ruby-test-string + "class C + | def foo + | 1 + | end + | + | def bar + | 2 + | end + | + | def baz + |some do + |3 + | end + | end + |end")) + +(defmacro ruby-deftest-move-to-block (name &rest body) + (declare (indent defun)) + `(ert-deftest ,(intern (format "ruby-move-to-block-%s" name)) () + (with-temp-buffer + (insert ruby-block-test-example) + (ruby-mode) + (goto-char (point-min)) + ,@body))) + +(ruby-deftest-move-to-block works-on-do + (forward-line 10) + (ruby-end-of-block) + (should (= 13 (line-number-at-pos))) + (ruby-beginning-of-block) + (should (= 11 (line-number-at-pos)))) + +(ruby-deftest-move-to-block zero-is-noop + (forward-line 4) + (ruby-move-to-block 0) + (should (= 5 (line-number-at-pos)))) + +(ruby-deftest-move-to-block ok-with-three + (forward-line 1) + (ruby-move-to-block 3) + (should (= 14 (line-number-at-pos)))) + +(ruby-deftest-move-to-block ok-with-minus-two + (forward-line 9) + (ruby-move-to-block -2) + (should (= 2 (line-number-at-pos)))) + +(ert-deftest ruby-move-to-block-skips-percent-literal () + (dolist (s (list (ruby-test-string + "foo do + | a = %%w( + | def yaa + | ) + |end") + (ruby-test-string + "foo do + | a = %%w| + | end + | | + |end"))) + (ruby-with-temp-buffer s + (goto-char (point-min)) + (ruby-end-of-block) + (should (= 5 (line-number-at-pos))) + (ruby-beginning-of-block) + (should (= 1 (line-number-at-pos)))))) + +(ert-deftest ruby-move-to-block-skips-heredoc () + (ruby-with-temp-buffer + (ruby-test-string + "if something_wrong? + | ActiveSupport::Deprecation.warn(<<-eowarn) + | boo hoo + | end + | eowarn + |end") + (goto-char (point-min)) + (ruby-end-of-block) + (should (= 6 (line-number-at-pos))) + (ruby-beginning-of-block) + (should (= 1 (line-number-at-pos))))) + +(ert-deftest ruby-move-to-block-does-not-fold-case () + (ruby-with-temp-buffer + (ruby-test-string + "foo do + | Module.to_s + |end") + (let ((case-fold-search t)) + (ruby-beginning-of-block)) + (should (= 1 (line-number-at-pos))))) + +(ert-deftest ruby-move-to-block-moves-from-else-to-if () + (ruby-with-temp-buffer (ruby-test-string + "if true + | nested_block do + | end + |else + |end") + (goto-char (point-min)) + (forward-line 3) + (ruby-beginning-of-block) + (should (= 1 (line-number-at-pos))))) + +(ert-deftest ruby-beginning-of-defun-does-not-fold-case () + (ruby-with-temp-buffer + (ruby-test-string + "class C + | def bar + | Class.to_s + | end + |end") + (goto-char (point-min)) + (forward-line 3) + (let ((case-fold-search t)) + (beginning-of-defun)) + (should (= 2 (line-number-at-pos))))) + +(ert-deftest ruby-end-of-defun-skips-to-next-line-after-the-method () + (ruby-with-temp-buffer + (ruby-test-string + "class D + | def tee + | 'ho hum' + | end + |end") + (goto-char (point-min)) + (forward-line 1) + (end-of-defun) + (should (= 5 (line-number-at-pos))))) + +(defvar ruby-sexp-test-example + (ruby-test-string + "class C + | def foo + | self.end + | D.new.class + | [1, 2, 3].map do |i| + | i + 1 + | end.sum + | end + |end")) + +(ert-deftest ruby-forward-sexp-skips-method-calls-with-keyword-names () + (ruby-with-temp-buffer ruby-sexp-test-example + (goto-line 2) + (ruby-forward-sexp) + (should (= 8 (line-number-at-pos))))) + +(ert-deftest ruby-backward-sexp-skips-method-calls-with-keyword-names () + (ruby-with-temp-buffer ruby-sexp-test-example + (goto-line 8) + (end-of-line) + (ruby-backward-sexp) + (should (= 2 (line-number-at-pos))))) + +(ert-deftest ruby-toggle-string-quotes-quotes-correctly () + (let ((pairs + '(("puts '\"foo\"\\''" . "puts \"\\\"foo\\\"'\"") + ("puts \"'foo'\\\"\"" . "puts '\\'foo\\'\"'")))) + (dolist (pair pairs) + (ruby-with-temp-buffer (car pair) + (beginning-of-line) + (search-forward "foo") + (ruby-toggle-string-quotes) + (should (string= (buffer-string) (cdr pair))))))) + +(ert-deftest ruby--insert-coding-comment-ruby-style () + (with-temp-buffer + (let ((ruby-encoding-magic-comment-style 'ruby)) + (ruby--insert-coding-comment "utf-8") + (should (string= "# coding: utf-8\n" (buffer-string)))))) + +(ert-deftest ruby--insert-coding-comment-emacs-style () + (with-temp-buffer + (let ((ruby-encoding-magic-comment-style 'emacs)) + (ruby--insert-coding-comment "utf-8") + (should (string= "# -*- coding: utf-8 -*-\n" (buffer-string)))))) + +(ert-deftest ruby--insert-coding-comment-custom-style () + (with-temp-buffer + (let ((ruby-encoding-magic-comment-style 'custom) + (ruby-custom-encoding-magic-comment-template "# encoding: %s\n")) + (ruby--insert-coding-comment "utf-8") + (should (string= "# encoding: utf-8\n\n" (buffer-string)))))) + + +(provide 'ruby-mode-tests) + +;;; ruby-mode-tests.el ends here diff --cc test/lisp/progmodes/subword-tests.el index 5a562765bb1,00000000000..39512efdbe1 mode 100644,000000..100644 --- a/test/lisp/progmodes/subword-tests.el +++ b/test/lisp/progmodes/subword-tests.el @@@ -1,81 -1,0 +1,81 @@@ +;;; subword-tests.el --- Testing the subword rules + - ;; Copyright (C) 2011-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2011-2017 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'subword) + +(defconst subword-tests-strings + '("ABC^" ;;Bug#13758 + "ABC^ ABC^Foo^ ABC^-Foo^ toto^ ABC^")) + +(ert-deftest subword-tests () + "Test the `subword-mode' rules." + (with-temp-buffer + (dolist (str subword-tests-strings) + (erase-buffer) + (insert str) + (goto-char (point-min)) + (while (search-forward "^" nil t) + (replace-match "")) + (goto-char (point-min)) + (while (not (eobp)) + (subword-forward 1) + (insert "^")) + (should (equal (buffer-string) str))))) + +(ert-deftest subword-tests2 () + "Test that motion in subword-mode stops at the right places." + + (let* ((line "fooBarBAZ quXD g_TESTThingAbc word BLAH test") + (fwrd "* * * * * * * * * * * * *") + (bkwd "* * * * * * * * * * * * *")) + + (with-temp-buffer + (subword-mode 1) + (insert line) + + ;; Test forward motion. + + (goto-char (point-min)) + (let ((stops (make-string (length fwrd) ?\ ))) + (while (progn + (aset stops (1- (point)) ?\*) + (not (eobp))) + (forward-word)) + (should (equal stops fwrd))) + + ;; Test backward motion. + + (goto-char (point-max)) + (let ((stops (make-string (length bkwd) ?\ ))) + (while (progn + (aset stops (1- (point)) ?\*) + (not (bobp))) + (backward-word)) + (should (equal stops bkwd)))))) + +(provide 'subword-tests) +;;; subword-tests.el ends here diff --cc test/lisp/progmodes/xref-tests.el index 2b745816c62,00000000000..b7f0f0526c6 mode 100644,000000..100644 --- a/test/lisp/progmodes/xref-tests.el +++ b/test/lisp/progmodes/xref-tests.el @@@ -1,91 -1,0 +1,91 @@@ +;;; xref-tests.el --- tests for xref + - ;; Copyright (C) 2016 Free Software Foundation, Inc. ++;; Copyright (C) 2016-2017 Free Software Foundation, Inc. + +;; Author: Dmitry Gutov + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'xref) +(require 'cl-lib) + +(defvar xref-tests-data-dir + (expand-file-name "data/xref/" + (getenv "EMACS_TEST_DIRECTORY"))) + +(ert-deftest xref-collect-matches-finds-none-for-some-regexp () + (should (null (xref-collect-matches "zzz" "*" xref-tests-data-dir nil)))) + +(ert-deftest xref-collect-matches-finds-some-for-bar () + (let* ((matches (xref-collect-matches "bar" "*" xref-tests-data-dir nil)) + (locs (cl-sort (mapcar #'xref-item-location matches) + #'string< + :key #'xref-location-group))) + (should (= 2 (length matches))) + (should (string-match-p "file1\\.txt\\'" (xref-location-group (nth 0 locs)))) + (should (string-match-p "file2\\.txt\\'" (xref-location-group (nth 1 locs)))))) + +(ert-deftest xref-collect-matches-finds-two-matches-on-the-same-line () + (let* ((matches (xref-collect-matches "foo" "*" xref-tests-data-dir nil)) + (locs (mapcar #'xref-item-location matches))) + (should (= 2 (length matches))) + (should (string-match-p "file1\\.txt\\'" (xref-location-group (nth 0 locs)))) + (should (string-match-p "file1\\.txt\\'" (xref-location-group (nth 1 locs)))) + (should (equal 1 (xref-location-line (nth 0 locs)))) + (should (equal 1 (xref-location-line (nth 1 locs)))) + (should (equal 0 (xref-file-location-column (nth 0 locs)))) + (should (equal 4 (xref-file-location-column (nth 1 locs)))))) + +(ert-deftest xref-collect-matches-finds-an-empty-line-regexp-match () + (let* ((matches (xref-collect-matches "^$" "*" xref-tests-data-dir nil)) + (locs (mapcar #'xref-item-location matches))) + (should (= 1 (length matches))) + (should (string-match-p "file2\\.txt\\'" (xref-location-group (nth 0 locs)))) + (should (equal 1 (xref-location-line (nth 0 locs)))) + (should (equal 0 (xref-file-location-column (nth 0 locs)))))) + +(ert-deftest xref--buf-pairs-iterator-groups-markers-by-buffers-1 () + (let* ((xrefs (xref-collect-matches "foo" "*" xref-tests-data-dir nil)) + (iter (xref--buf-pairs-iterator xrefs)) + (cons (funcall iter :next))) + (should (null (funcall iter :next))) + (should (string-match "file1\\.txt\\'" (buffer-file-name (car cons)))) + (should (= 2 (length (cdr cons)))))) + +(ert-deftest xref--buf-pairs-iterator-groups-markers-by-buffers-2 () + (let* ((xrefs (xref-collect-matches "bar" "*" xref-tests-data-dir nil)) + (iter (xref--buf-pairs-iterator xrefs)) + (cons1 (funcall iter :next)) + (cons2 (funcall iter :next))) + (should (null (funcall iter :next))) + (should-not (equal (car cons1) (car cons2))) + (should (= 1 (length (cdr cons1)))) + (should (= 1 (length (cdr cons2)))))) + +(ert-deftest xref--buf-pairs-iterator-cleans-up-markers () + (let* ((xrefs (xref-collect-matches "bar" "*" xref-tests-data-dir nil)) + (iter (xref--buf-pairs-iterator xrefs)) + (cons1 (funcall iter :next)) + (cons2 (funcall iter :next))) + (funcall iter :cleanup) + (should (null (marker-position (car (nth 0 (cdr cons1)))))) + (should (null (marker-position (cdr (nth 0 (cdr cons1)))))) + (should (null (marker-position (car (nth 0 (cdr cons2)))))) + (should (null (marker-position (cdr (nth 0 (cdr cons2)))))))) diff --cc test/lisp/replace-tests.el index 2b71348f350,00000000000..adef5a3f3dc mode 100644,000000..100644 --- a/test/lisp/replace-tests.el +++ b/test/lisp/replace-tests.el @@@ -1,361 -1,0 +1,361 @@@ +;;; replace-tests.el --- tests for replace.el. + - ;; Copyright (C) 2010-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2010-2017 Free Software Foundation, Inc. + +;; Author: Nicolas Richard +;; Author: Juri Linkov + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) + +(ert-deftest query-replace--split-string-tests () + (let ((sep (propertize "\0" 'separator t))) + (dolist (before '("" "b")) + (dolist (after '("" "a")) + (should (equal + (query-replace--split-string (concat before sep after)) + (cons before after))) + (should (equal + (query-replace--split-string (concat before "\0" after)) + (concat before "\0" after))))))) + +(defconst replace-occur-tests + '( + ;; * Test one-line matches (at bob, eob, bol, eol). + ("x" 0 "\ +xa +b +cx +xd +xex +fx +" "\ +6 matches in 5 lines for \"x\" in buffer: *test-occur* + 1:xa + 3:cx + 4:xd + 5:xex + 6:fx +") + ;; * Test multi-line matches, this is the first test from + ;; http://lists.gnu.org/archive/html/emacs-devel/2005-06/msg01008.html + ;; where numbers are replaced with letters. + ("a\na" 0 "\ +a +a +a +a +a +" "\ +2 matches for \"a\na\" in buffer: *test-occur* + 1:a + :a + 3:a + :a +") + ;; * Test multi-line matches, this is the second test from + ;; http://lists.gnu.org/archive/html/emacs-devel/2005-06/msg01008.html + ;; where numbers are replaced with letters. + ("a\nb" 0 "\ +a +b +c +a +b +" "\ +2 matches for \"a\nb\" in buffer: *test-occur* + 1:a + :b + 4:a + :b +") + ;; * Test line numbers for multi-line matches with empty last match line. + ("a\n" 0 "\ +a + +c +a + +" "\ +2 matches for \"a\n\" in buffer: *test-occur* + 1:a + : + 4:a + : +") + ;; * Test multi-line matches with 3 match lines. + ("x\n.x\n" 0 "\ +ax +bx +c +d +ex +fx +" "\ +2 matches for \"x\n.x\n\" in buffer: *test-occur* + 1:ax + :bx + :c + 5:ex + :fx + : +") + ;; * Test non-overlapping context lines with matches at bob/eob. + ("x" 1 "\ +ax +b +c +d +ex +f +g +hx +" "\ +3 matches for \"x\" in buffer: *test-occur* + 1:ax + :b +------- + :d + 5:ex + :f +------- + :g + 8:hx +") + ;; * Test non-overlapping context lines with matches not at bob/eob. + ("x" 1 "\ +a +bx +c +d +ex +f +" "\ +2 matches for \"x\" in buffer: *test-occur* + :a + 2:bx + :c +------- + :d + 5:ex + :f +") + ;; * Test overlapping context lines with matches at bob/eob. + ("x" 2 "\ +ax +bx +c +dx +e +f +gx +h +i +j +kx +" "\ +5 matches for \"x\" in buffer: *test-occur* + 1:ax + 2:bx + :c + 4:dx + :e + :f + 7:gx + :h + :i + :j + 11:kx +") + ;; * Test overlapping context lines with matches not at bob/eob. + ("x" 2 "\ +a +b +cx +d +e +f +gx +h +i +" "\ +2 matches for \"x\" in buffer: *test-occur* + :a + :b + 3:cx + :d + :e + :f + 7:gx + :h + :i +") + ;; * Test overlapping context lines with empty first and last line.. + ("x" 2 "\ + +b +cx +d +e +f +gx +h + +" "\ +2 matches for \"x\" in buffer: *test-occur* + : + :b + 3:cx + :d + :e + :f + 7:gx + :h + : +") + ;; * Test multi-line overlapping context lines. + ("x\n.x" 2 "\ +ax +bx +c +d +ex +fx +g +h +i +jx +kx +" "\ +3 matches for \"x\n.x\" in buffer: *test-occur* + 1:ax + :bx + :c + :d + 5:ex + :fx + :g + :h + :i + 10:jx + :kx +") + ;; * Test multi-line non-overlapping context lines. + ("x\n.x" 2 "\ +ax +bx +c +d +e +f +gx +hx +" "\ +2 matches for \"x\n.x\" in buffer: *test-occur* + 1:ax + :bx + :c + :d +------- + :e + :f + 7:gx + :hx +") + ;; * Test non-overlapping negative (before-context) lines. + ("x" -2 "\ +a +bx +c +d +e +fx +g +h +ix +" "\ +3 matches for \"x\" in buffer: *test-occur* + :a + 2:bx +------- + :d + :e + 6:fx +------- + :g + :h + 9:ix +") + ;; * Test overlapping negative (before-context) lines. + ("x" -3 "\ +a +bx +c +dx +e +f +gx +h +" "\ +3 matches for \"x\" in buffer: *test-occur* + :a + 2:bx + :c + 4:dx + :e + :f + 7:gx +") + +) + "List of tests for `occur'. +Each element has the format: +\(REGEXP NLINES INPUT-BUFFER-STRING OUTPUT-BUFFER-STRING).") + +(defun replace-occur-test-case (test) + (let ((regexp (nth 0 test)) + (nlines (nth 1 test)) + (input-buffer-string (nth 2 test)) + (temp-buffer (get-buffer-create " *test-occur*"))) + (unwind-protect + (save-window-excursion + (with-current-buffer temp-buffer + (erase-buffer) + (insert input-buffer-string) + (occur regexp nlines) + (with-current-buffer "*Occur*" + (buffer-substring-no-properties (point-min) (point-max))))) + (and (buffer-name temp-buffer) + (kill-buffer temp-buffer))))) + +(defun replace-occur-test-create (n) + "Create a test for element N of the `replace-occur-tests' constant." + (let ((testname (intern (format "occur-test-%.2d" n))) + (testdoc (format "Test element %d of `replace-occur-tests'." n))) + (eval + `(ert-deftest ,testname () + ,testdoc + (let (replace-occur-hook) + (should (equal (replace-occur-test-case (nth ,n replace-occur-tests)) + (nth 3 (nth ,n replace-occur-tests))))))))) + +(dotimes (i (length replace-occur-tests)) + (replace-occur-test-create i)) + +;;; replace-tests.el ends here diff --cc test/lisp/simple-tests.el index d022240ae5c,00000000000..6194cada1c6 mode 100644,000000..100644 --- a/test/lisp/simple-tests.el +++ b/test/lisp/simple-tests.el @@@ -1,378 -1,0 +1,378 @@@ +;;; simple-test.el --- Tests for simple.el -*- lexical-binding: t; -*- + - ;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2017 Free Software Foundation, Inc. + +;; Author: Artur Malabarba + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'ert) + +(defmacro simple-test--dummy-buffer (&rest body) + (declare (indent 0) + (debug t)) + `(with-temp-buffer + (emacs-lisp-mode) + (setq indent-tabs-mode nil) + (insert "(a b") + (save-excursion (insert " c d)")) + ,@body + (cons (buffer-substring (point-min) (point)) + (buffer-substring (point) (point-max))))) + + +(defmacro simple-test--transpositions (&rest body) + (declare (indent 0) + (debug t)) + `(with-temp-buffer + (emacs-lisp-mode) + (insert "(s1) (s2) (s3) (s4) (s5)") + (backward-sexp 1) + ,@body + (cons (buffer-substring (point-min) (point)) + (buffer-substring (point) (point-max))))) + + +;;; `newline' +(ert-deftest newline () + (should-error (newline -1)) + (should (equal (simple-test--dummy-buffer (newline 1)) + '("(a b\n" . " c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-mode -1) + (call-interactively #'newline)) + '("(a b\n" . " c d)"))) + (should (equal (simple-test--dummy-buffer + (let ((current-prefix-arg 5)) + (call-interactively #'newline))) + '("(a b\n\n\n\n\n" . " c d)"))) + (should (equal (simple-test--dummy-buffer (newline 5)) + '("(a b\n\n\n\n\n" . " c d)"))) + (should (equal (simple-test--dummy-buffer + (forward-char 1) + (newline 1)) + '("(a b \n" . "c d)")))) + +(ert-deftest newline-indent () + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (newline 1)) + '("(a b\n" . " c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (newline 1 'interactive)) + '("(a b\n " . "c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (let ((current-prefix-arg nil)) + (call-interactively #'newline) + (call-interactively #'newline))) + '("(a b\n\n " . "c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (newline 5 'interactive)) + '("(a b\n\n\n\n\n " . "c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (let ((current-prefix-arg 5)) + (call-interactively #'newline))) + '("(a b\n\n\n\n\n " . "c d)"))) + (should (equal (simple-test--dummy-buffer + (forward-char 1) + (electric-indent-local-mode 1) + (newline 1 'interactive)) + '("(a b\n " . "c d)")))) + + +;;; `open-line' +(ert-deftest open-line () + (should-error (open-line -1)) + (should-error (open-line)) + (should (equal (simple-test--dummy-buffer (open-line 1)) + '("(a b" . "\n c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-mode -1) + (call-interactively #'open-line)) + '("(a b" . "\n c d)"))) + (should (equal (simple-test--dummy-buffer + (let ((current-prefix-arg 5)) + (call-interactively #'open-line))) + '("(a b" . "\n\n\n\n\n c d)"))) + (should (equal (simple-test--dummy-buffer (open-line 5)) + '("(a b" . "\n\n\n\n\n c d)"))) + (should (equal (simple-test--dummy-buffer + (forward-char 1) + (open-line 1)) + '("(a b " . "\nc d)")))) + +(ert-deftest open-line-margin-and-prefix () + (should (equal (simple-test--dummy-buffer + (let ((left-margin 10)) + (open-line 3))) + '("(a b" . "\n\n\n c d)"))) + (should (equal (simple-test--dummy-buffer + (forward-line 0) + (let ((left-margin 2)) + (open-line 1))) + '(" " . "\n (a b c d)"))) + (should (equal (simple-test--dummy-buffer + (let ((fill-prefix "- - ")) + (open-line 1))) + '("(a b" . "\n c d)"))) + (should (equal (simple-test--dummy-buffer + (forward-line 0) + (let ((fill-prefix "- - ")) + (open-line 1))) + '("- - " . "\n(a b c d)")))) + +;; For a while, from 24 Oct - 21 Nov 2015, `open-line' in the Emacs +;; development tree became sensitive to `electric-indent-mode', which +;; it had not been before. This sensitivity was reverted for the +;; Emacs 25 release, so it could be discussed further (see thread +;; "Questioning the new behavior of `open-line'." on the Emacs Devel +;; mailing list, and bug #21884). +(ert-deftest open-line-indent () + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (open-line 1)) + '("(a b" . "\n c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (open-line 1)) + '("(a b" . "\n c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (let ((current-prefix-arg nil)) + (call-interactively #'open-line) + (call-interactively #'open-line))) + '("(a b" . "\n\n c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (open-line 5)) + '("(a b" . "\n\n\n\n\n c d)"))) + (should (equal (simple-test--dummy-buffer + (electric-indent-local-mode 1) + (let ((current-prefix-arg 5)) + (call-interactively #'open-line))) + '("(a b" . "\n\n\n\n\n c d)"))) + (should (equal (simple-test--dummy-buffer + (forward-char 1) + (electric-indent-local-mode 1) + (open-line 1)) + '("(a b " . "\nc d)")))) + +;; From 24 Oct - 21 Nov 2015, `open-line' took a second argument +;; INTERACTIVE and ran `post-self-insert-hook' if the argument was +;; true. This test tested that. Currently, however, `open-line' +;; does not run run `post-self-insert-hook' at all, so for now +;; this test just makes sure that it doesn't. +(ert-deftest open-line-hook () + (let* ((x 0) + (inc (lambda () (setq x (1+ x))))) + (simple-test--dummy-buffer + (add-hook 'post-self-insert-hook inc nil 'local) + (open-line 1)) + (should (= x 0)) + (simple-test--dummy-buffer + (add-hook 'post-self-insert-hook inc nil 'local) + (open-line 1)) + (should (= x 0)) + + (unwind-protect + (progn + (add-hook 'post-self-insert-hook inc) + (simple-test--dummy-buffer + (open-line 1)) + (should (= x 0)) + (simple-test--dummy-buffer + (open-line 10)) + (should (= x 0))) + (remove-hook 'post-self-insert-hook inc)))) + + +;;; `delete-trailing-whitespace' +(ert-deftest simple-delete-trailing-whitespace--bug-21766 () + "Test bug#21766: delete-whitespace sometimes deletes non-whitespace." + (defvar python-indent-guess-indent-offset) ; to avoid a warning + (let ((python (featurep 'python)) + (python-indent-guess-indent-offset nil) + (delete-trailing-lines t)) + (unwind-protect + (with-temp-buffer + (python-mode) + (insert (concat "query = \"\"\"WITH filtered AS \n" + "WHERE \n" + "\"\"\".format(fv_)\n" + "\n" + "\n")) + (delete-trailing-whitespace) + (should (string-equal (buffer-string) + (concat "query = \"\"\"WITH filtered AS\n" + "WHERE\n" + "\"\"\".format(fv_)\n")))) + ;; Let's clean up if running interactive + (unless (or noninteractive python) + (unload-feature 'python))))) + +(ert-deftest simple-delete-trailing-whitespace--formfeeds () + "Test formfeeds are not deleted but whitespace past them is." + (with-temp-buffer + (with-syntax-table (make-syntax-table) + (modify-syntax-entry ?\f " ") ; Make sure \f is whitespace + (insert " \f \n \f \f \n\nlast\n") + (delete-trailing-whitespace) + (should (string-equal (buffer-string) " \f\n \f \f\n\nlast\n")) + (should (equal ?\s (char-syntax ?\f))) + (should (equal ?\s (char-syntax ?\n)))))) + + +;;; auto-boundary tests +(ert-deftest undo-auto-boundary-timer () + (should + undo-auto-current-boundary-timer)) + +(ert-deftest undo-auto--boundaries-added () + ;; The change in the buffer should have caused addition + ;; to undo-auto--undoably-changed-buffers. + (should + (with-temp-buffer + (setq buffer-undo-list nil) + (insert "hello") + (member (current-buffer) undo-auto--undoably-changed-buffers))) + ;; The head of buffer-undo-list should be the insertion event, and + ;; therefore not nil + (should + (with-temp-buffer + (setq buffer-undo-list nil) + (insert "hello") + (car buffer-undo-list))) + ;; Now the head of the buffer-undo-list should be a boundary and so + ;; nil. We have to call auto-boundary explicitly because we are out + ;; of the command loop + (should-not + (with-temp-buffer + (setq buffer-undo-list nil) + (insert "hello") + (car buffer-undo-list) + (undo-auto--boundaries 'test)))) + +;;; Transposition with negative args (bug#20698, bug#21885) +(ert-deftest simple-transpose-subr () + (should (equal (simple-test--transpositions (transpose-sexps -1)) + '("(s1) (s2) (s4)" . " (s3) (s5)"))) + (should (equal (simple-test--transpositions (transpose-sexps -2)) + '("(s1) (s4)" . " (s2) (s3) (s5)")))) + + +;; Test for a regression introduced by undo-auto--boundaries changes. +;; https://lists.gnu.org/archive/html/emacs-devel/2015-11/msg01652.html +(defun undo-test-kill-c-a-then-undo () + (with-temp-buffer + (switch-to-buffer (current-buffer)) + (setq buffer-undo-list nil) + (insert "a\nb\n\c\n") + (goto-char (point-max)) + ;; We use a keyboard macro because it adds undo events in the same + ;; way as if a user were involved. + (kmacro-call-macro nil nil nil + [left + ;; Delete "c" + backspace + left left left + ;; Delete "a" + backspace + ;; C-/ or undo + 67108911 + ]) + (point))) + +(defun undo-test-point-after-forward-kill () + (with-temp-buffer + (switch-to-buffer (current-buffer)) + (setq buffer-undo-list nil) + (insert "kill word forward") + ;; Move to word "word". + (goto-char 6) + (kmacro-call-macro nil nil nil + [ + ;; kill-word + C-delete + ;; undo + 67108911 + ]) + (point))) + +(ert-deftest undo-point-in-wrong-place () + (should + ;; returns 5 with the bug + (= 2 + (undo-test-kill-c-a-then-undo))) + (should + (= 6 + (undo-test-point-after-forward-kill)))) + +(defmacro simple-test-undo-with-switched-buffer (buffer &rest body) + (declare (indent 1) (debug t)) + (let ((before-buffer (make-symbol "before-buffer"))) + `(let ((,before-buffer (current-buffer))) + (unwind-protect + (progn + (switch-to-buffer ,buffer) + ,@body) + (switch-to-buffer ,before-buffer))))) + +;; This tests for a regression in emacs 25.0 see bug #23632 +(ert-deftest simple-test-undo-extra-boundary-in-tex () + (should + (string= + "" + (simple-test-undo-with-switched-buffer + "temp.tex" + (latex-mode) + ;; This macro calls `latex-insert-block' + (execute-kbd-macro + (read-kbd-macro + " +C-c C-o ;; latex-insert-block +RET ;; newline +C-/ ;; undo +" + )) + (buffer-substring-no-properties + (point-min) + (point-max)))))) + +(ert-deftest missing-record-point-in-undo () + "Check point is being restored correctly. + +See Bug#21722." + (should + (= 5 + (with-temp-buffer + (generate-new-buffer " *temp*") + (emacs-lisp-mode) + (setq buffer-undo-list nil) + (insert "(progn (end-of-line) (insert \"hello\"))") + (beginning-of-line) + (forward-char 4) + (undo-boundary) + (eval-defun nil) + (undo-boundary) + (undo) + (point))))) + +(provide 'simple-test) +;;; simple-test.el ends here diff --cc test/lisp/sort-tests.el index f3a182cdc14,00000000000..f6cbe90d5bf mode 100644,000000..100644 --- a/test/lisp/sort-tests.el +++ b/test/lisp/sort-tests.el @@@ -1,108 -1,0 +1,108 @@@ +;;; sort-tests.el --- Tests for sort.el -*- lexical-binding: t; -*- + - ;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2017 Free Software Foundation, Inc. + +;; Author: Artur Malabarba + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'ert) +(require 'sort) + +(defun sort-tests-random-word (n) + (mapconcat (lambda (_) (string (let ((c (random 52))) + (+ (if (> c 25) 71 65) + c)))) + (make-list n nil) "")) + +(defun sort-tests--insert-words-sort-and-compare (words separator function reverse less-predicate) + (with-temp-buffer + (let ((aux words)) + (while aux + (insert (pop aux)) + (when aux + (insert separator)))) + ;; Final newline. + (insert "\n") + (funcall function reverse (point-min) (point-max)) + (let ((sorted-words + (mapconcat #'identity + (sort (copy-sequence words) + (if reverse + (lambda (a b) (funcall less-predicate b a)) + less-predicate)) + separator))) + (should (string= (substring (buffer-string) 0 -1) sorted-words))))) + +;;; This function uses randomly generated tests and should satisfy +;;; most needs for this lib. +(cl-defun sort-tests-test-sorter-function (separator function &key generator less-pred noreverse) + "Check that FUNCTION correctly sorts words separated by SEPARATOR. +This checks whether it is equivalent to sorting a list of such +words via LESS-PREDICATE, and then inserting them separated by +SEPARATOR. +LESS-PREDICATE defaults to `string-lessp'. +GENERATOR is a function called with one argument that returns a +word, it defaults to `sort-tests-random-word'. +NOREVERSE means that the first arg of FUNCTION is not used for +reversing the sort." + (dotimes (n 20) + ;; Sort n words of length n. + (let ((words (mapcar (or generator #'sort-tests-random-word) (make-list n n))) + (sort-fold-case nil) + (less-pred (or less-pred #'string<))) + (sort-tests--insert-words-sort-and-compare words separator function nil less-pred) + (unless noreverse + (sort-tests--insert-words-sort-and-compare + words separator function 'reverse less-pred)) + (let ((less-pred-case (lambda (a b) (funcall less-pred (downcase a) (downcase b)))) + (sort-fold-case t)) + (sort-tests--insert-words-sort-and-compare words separator function nil less-pred-case) + (unless noreverse + (sort-tests--insert-words-sort-and-compare + words separator function 'reverse less-pred-case)))))) + +(ert-deftest sort-tests--lines () + (sort-tests-test-sorter-function "\n" #'sort-lines)) + +(ert-deftest sort-tests--paragraphs () + (let ((paragraph-separate "[\s\t\f]*$")) + (sort-tests-test-sorter-function "\n\n" #'sort-paragraphs))) + +(ert-deftest sort-tests--numeric-fields () + (cl-labels ((field-to-number (f) (string-to-number (car (split-string f))))) + (sort-tests-test-sorter-function "\n" (lambda (_ l r) (sort-numeric-fields 1 l (1- r))) + :noreverse t + :generator (lambda (_) (format "%s %s" (random) (sort-tests-random-word 20))) + :less-pred (lambda (a b) (< (field-to-number a) + (field-to-number b)))))) + +(ert-deftest sort-tests--fields-1 () + (cl-labels ((field-n (f n) (elt (split-string f) (1- n)))) + (sort-tests-test-sorter-function "\n" (lambda (_ l r) (sort-fields 1 l (1- r))) + :noreverse t + :generator (lambda (n) (concat (sort-tests-random-word n) " " (sort-tests-random-word n))) + :less-pred (lambda (a b) (string< (field-n a 1) (field-n b 1)))))) + +(ert-deftest sort-tests--fields-2 () + (cl-labels ((field-n (f n) (elt (split-string f) (1- n)))) + (sort-tests-test-sorter-function "\n" (lambda (_ l r) (sort-fields 2 l (1- r))) + :noreverse t + :generator (lambda (n) (concat (sort-tests-random-word n) " " (sort-tests-random-word n))) + :less-pred (lambda (a b) (string< (field-n a 2) (field-n b 2)))))) + +(provide 'sort-tests) +;;; sort-tests.el ends here diff --cc test/lisp/subr-tests.el index 82a70ca072b,00000000000..3c5dbcdbd76 mode 100644,000000..100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@@ -1,275 -1,0 +1,275 @@@ +;;; subr-tests.el --- Tests for subr.el + - ;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2017 Free Software Foundation, Inc. + +;; Author: Oleh Krehel , +;; Nicolas Petton +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) + +(ert-deftest let-when-compile () + ;; good case + (should (equal (macroexpand '(let-when-compile ((foo (+ 2 3))) + (setq bar (eval-when-compile (+ foo foo))) + (setq boo (eval-when-compile (* foo foo))))) + '(progn + (setq bar (quote 10)) + (setq boo (quote 25))))) + ;; bad case: `eval-when-compile' omitted, byte compiler should catch this + (should (equal (macroexpand + '(let-when-compile ((foo (+ 2 3))) + (setq bar (+ foo foo)) + (setq boo (eval-when-compile (* foo foo))))) + '(progn + (setq bar (+ foo foo)) + (setq boo (quote 25))))) + ;; something practical + (should (equal (macroexpand + '(let-when-compile ((keywords '("true" "false"))) + (font-lock-add-keywords + 'c++-mode + `((,(eval-when-compile + (format "\\<%s\\>" (regexp-opt keywords))) + 0 font-lock-keyword-face))))) + '(font-lock-add-keywords + (quote c++-mode) + (list + (cons (quote + "\\<\\(?:\\(?:fals\\|tru\\)e\\)\\>") + (quote + (0 font-lock-keyword-face)))))))) + +(ert-deftest number-sequence-test () + (should (= (length + (number-sequence (1- most-positive-fixnum) most-positive-fixnum)) + 2)) + (should (= (length + (number-sequence + (1+ most-negative-fixnum) most-negative-fixnum -1)) + 2))) + +(ert-deftest string-comparison-test () + (should (string-lessp "abc" "acb")) + (should (string-lessp "aBc" "abc")) + (should (string-lessp "abc" "abcd")) + (should (string-lessp "abc" "abcd")) + (should-not (string-lessp "abc" "abc")) + (should-not (string-lessp "" "")) + + (should (string-greaterp "acb" "abc")) + (should (string-greaterp "abc" "aBc")) + (should (string-greaterp "abcd" "abc")) + (should (string-greaterp "abcd" "abc")) + (should-not (string-greaterp "abc" "abc")) + (should-not (string-greaterp "" "")) + + ;; Symbols are also accepted + (should (string-lessp 'abc 'acb)) + (should (string-lessp "abc" 'acb)) + (should (string-greaterp 'acb 'abc)) + (should (string-greaterp "acb" 'abc))) + +(ert-deftest subr-test-when () + (should (equal (when t 1) 1)) + (should (equal (when t 2) 2)) + (should (equal (when nil 1) nil)) + (should (equal (when nil 2) nil)) + (should (equal (when t 'x 1) 1)) + (should (equal (when t 'x 2) 2)) + (should (equal (when nil 'x 1) nil)) + (should (equal (when nil 'x 2) nil)) + (let ((x 1)) + (should-not (when nil + (setq x (1+ x)) + x)) + (should (= x 1)) + (should (= 2 (when t + (setq x (1+ x)) + x))) + (should (= x 2))) + (should (equal (macroexpand-all '(when a b c d)) + '(if a (progn b c d))))) + +(ert-deftest subr-test-version-parsing () + (should (equal (version-to-list ".5") '(0 5))) + (should (equal (version-to-list "0.9 alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0.9 snapshot") '(0 9 -4))) + (should (equal (version-to-list "0.9-alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0.9-snapshot") '(0 9 -4))) + (should (equal (version-to-list "0.9.snapshot") '(0 9 -4))) + (should (equal (version-to-list "0.9_snapshot") '(0 9 -4))) + (should (equal (version-to-list "0.9alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0.9snapshot") '(0 9 -4))) + (should (equal (version-to-list "1.0 git") '(1 0 -4))) + (should (equal (version-to-list "1.0 pre2") '(1 0 -1 2))) + (should (equal (version-to-list "1.0-git") '(1 0 -4))) + (should (equal (version-to-list "1.0-pre2") '(1 0 -1 2))) + (should (equal (version-to-list "1.0.1-a") '(1 0 1 1))) + (should (equal (version-to-list "1.0.1-f") '(1 0 1 6))) + (should (equal (version-to-list "1.0.1.a") '(1 0 1 1))) + (should (equal (version-to-list "1.0.1.f") '(1 0 1 6))) + (should (equal (version-to-list "1.0.1_a") '(1 0 1 1))) + (should (equal (version-to-list "1.0.1_f") '(1 0 1 6))) + (should (equal (version-to-list "1.0.1a") '(1 0 1 1))) + (should (equal (version-to-list "1.0.1f") '(1 0 1 6))) + (should (equal (version-to-list "1.0.7.5") '(1 0 7 5))) + (should (equal (version-to-list "1.0.git") '(1 0 -4))) + (should (equal (version-to-list "1.0.pre2") '(1 0 -1 2))) + (should (equal (version-to-list "1.0_git") '(1 0 -4))) + (should (equal (version-to-list "1.0_pre2") '(1 0 -1 2))) + (should (equal (version-to-list "1.0git") '(1 0 -4))) + (should (equal (version-to-list "1.0pre2") '(1 0 -1 2))) + (should (equal (version-to-list "22.8 beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22.8-beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22.8.beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22.8_beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22.8beta3") '(22 8 -2 3))) + (should (equal (version-to-list "6.9.30 Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6.9.30-Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6.9.30.Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6.9.30Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6.9.30_Beta") '(6 9 30 -2))) + + (should (equal + (error-message-string (should-error (version-to-list "OTP-18.1.5"))) + "Invalid version syntax: `OTP-18.1.5' (must start with a number)")) + (should (equal + (error-message-string (should-error (version-to-list ""))) + "Invalid version syntax: `' (must start with a number)")) + (should (equal + (error-message-string (should-error (version-to-list "1.0..7.5"))) + "Invalid version syntax: `1.0..7.5'")) + (should (equal + (error-message-string (should-error (version-to-list "1.0prepre2"))) + "Invalid version syntax: `1.0prepre2'")) + (should (equal + (error-message-string (should-error (version-to-list "22.8X3"))) + "Invalid version syntax: `22.8X3'")) + (should (equal + (error-message-string (should-error (version-to-list "beta22.8alpha3"))) + "Invalid version syntax: `beta22.8alpha3' (must start with a number)")) + (should (equal + (error-message-string (should-error (version-to-list "honk"))) + "Invalid version syntax: `honk' (must start with a number)")) + (should (equal + (error-message-string (should-error (version-to-list 9))) + "Version must be a string")) + + (let ((version-separator "_")) + (should (equal (version-to-list "_5") '(0 5))) + (should (equal (version-to-list "0_9 alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0_9 snapshot") '(0 9 -4))) + (should (equal (version-to-list "0_9-alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0_9-snapshot") '(0 9 -4))) + (should (equal (version-to-list "0_9.alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0_9.snapshot") '(0 9 -4))) + (should (equal (version-to-list "0_9alpha1") '(0 9 -3 1))) + (should (equal (version-to-list "0_9snapshot") '(0 9 -4))) + (should (equal (version-to-list "1_0 git") '(1 0 -4))) + (should (equal (version-to-list "1_0 pre2") '(1 0 -1 2))) + (should (equal (version-to-list "1_0-git") '(1 0 -4))) + (should (equal (version-to-list "1_0.pre2") '(1 0 -1 2))) + (should (equal (version-to-list "1_0_1-a") '(1 0 1 1))) + (should (equal (version-to-list "1_0_1-f") '(1 0 1 6))) + (should (equal (version-to-list "1_0_1.a") '(1 0 1 1))) + (should (equal (version-to-list "1_0_1.f") '(1 0 1 6))) + (should (equal (version-to-list "1_0_1_a") '(1 0 1 1))) + (should (equal (version-to-list "1_0_1_f") '(1 0 1 6))) + (should (equal (version-to-list "1_0_1a") '(1 0 1 1))) + (should (equal (version-to-list "1_0_1f") '(1 0 1 6))) + (should (equal (version-to-list "1_0_7_5") '(1 0 7 5))) + (should (equal (version-to-list "1_0_git") '(1 0 -4))) + (should (equal (version-to-list "1_0pre2") '(1 0 -1 2))) + (should (equal (version-to-list "22_8 beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22_8-beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22_8.beta3") '(22 8 -2 3))) + (should (equal (version-to-list "22_8beta3") '(22 8 -2 3))) + (should (equal (version-to-list "6_9_30 Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6_9_30-Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6_9_30.Beta") '(6 9 30 -2))) + (should (equal (version-to-list "6_9_30Beta") '(6 9 30 -2))) + + (should (equal + (error-message-string (should-error (version-to-list "1_0__7_5"))) + "Invalid version syntax: `1_0__7_5'")) + (should (equal + (error-message-string (should-error (version-to-list "1_0prepre2"))) + "Invalid version syntax: `1_0prepre2'")) + (should (equal + (error-message-string (should-error (version-to-list "22.8X3"))) + "Invalid version syntax: `22.8X3'")) + (should (equal + (error-message-string (should-error (version-to-list "beta22_8alpha3"))) + "Invalid version syntax: `beta22_8alpha3' (must start with a number)")))) + +(defun subr-test--backtrace-frames-with-backtrace-frame (base) + "Reference implementation of `backtrace-frames'." + (let ((idx 0) + (frame nil) + (frames nil)) + (while (setq frame (backtrace-frame idx base)) + (push frame frames) + (setq idx (1+ idx))) + (nreverse frames))) + +(defun subr-test--frames-2 (base) + (let ((_dummy nil)) + (progn ;; Add a few frames to top of stack + (unwind-protect + (cons (mapcar (pcase-lambda (`(,evald ,func ,args ,_)) + `(,evald ,func ,@args)) + (backtrace-frames base)) + (subr-test--backtrace-frames-with-backtrace-frame base)))))) + +(defun subr-test--frames-1 (base) + (subr-test--frames-2 base)) + +(ert-deftest subr-test-backtrace-simple-tests () + "Test backtrace-related functions (simple tests). +This exercises `backtrace-frame', and indirectly `mapbacktrace'." + ;; `mapbacktrace' returns nil + (should (equal (mapbacktrace #'ignore) nil)) + ;; Unbound BASE is silently ignored + (let ((unbound (make-symbol "ub"))) + (should (equal (backtrace-frame 0 unbound) nil)) + (should (equal (mapbacktrace #'error unbound) nil))) + ;; First frame is backtrace-related function + (should (equal (backtrace-frame 0) '(t backtrace-frame 0))) + (should (equal (catch 'ret + (mapbacktrace (lambda (&rest args) (throw 'ret args)))) + '(t mapbacktrace ((lambda (&rest args) (throw 'ret args))) nil))) + ;; Past-end NFRAMES is silently ignored + (should (equal (backtrace-frame most-positive-fixnum) nil))) + +(ert-deftest subr-test-backtrace-integration-test () + "Test backtrace-related functions (integration test). +This exercises `backtrace-frame', `backtrace-frames', and +indirectly `mapbacktrace'." + ;; Compare two implementations of backtrace-frames + (let ((frame-lists (subr-test--frames-1 'subr-test--frames-2))) + (should (equal (car frame-lists) (cdr frame-lists))))) + +(provide 'subr-tests) +;;; subr-tests.el ends here diff --cc test/lisp/textmodes/reftex-tests.el index 12ec7f5a394,00000000000..55db66c58dc mode 100644,000000..100644 --- a/test/lisp/textmodes/reftex-tests.el +++ b/test/lisp/textmodes/reftex-tests.el @@@ -1,223 -1,0 +1,223 @@@ +;;; reftex-tests.el --- Test suite for reftex. -*- lexical-binding: t -*- + - ;; Copyright (C) 2013-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2013-2017 Free Software Foundation, Inc. + +;; Author: Rüdiger Sonderfeld +;; Keywords: internal +;; Human-Keywords: internal + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) + +;;; reftex +(require 'reftex) + +;;; reftex-parse +(require 'reftex-parse) + +(ert-deftest reftex-locate-bibliography-files () + "Test `reftex-locate-bibliography-files'." + (let ((temp-dir (make-temp-file "reftex-bib" 'dir)) + (files '("ref1.bib" "ref2.bib")) + (test '(("\\addbibresource{ref1.bib}\n" . ("ref1.bib")) + ("\\\\addbibresource[label=x]{ref2.bib}\\n" . ("ref2.bib")) + ("\\begin{document}\n\\bibliographystyle{plain}\n +\\bibliography{ref1,ref2}\n\\end{document}" . ("ref1.bib" "ref2.bib")))) + (reftex-bibliography-commands + ;; Default value: See reftex-vars.el `reftex-bibliography-commands' + '("bibliography" "nobibliography" "setupbibtex\\[.*?database=" + "addbibresource"))) + (with-temp-buffer + (insert "test\n") + (mapc + (lambda (file) + (write-region (point-min) (point-max) (expand-file-name file + temp-dir))) + files)) + (mapc + (lambda (data) + (with-temp-buffer + (insert (car data)) + (let ((res (mapcar #'file-name-nondirectory + (reftex-locate-bibliography-files temp-dir)))) + (should (equal res (cdr data)))))) + test) + (delete-directory temp-dir 'recursive))) + +(ert-deftest reftex-what-environment-test () + "Test `reftex-what-environment'." + (with-temp-buffer + (insert "\\begin{equation}\n x=y^2\n") + (let ((pt (point)) + pt2) + (insert "\\end{equation}\n") + (goto-char pt) + + (should (equal (reftex-what-environment 1) '("equation" . 1))) + (should (equal (reftex-what-environment t) '(("equation" . 1)))) + + (insert "\\begin{something}\nxxx") + (setq pt2 (point)) + (insert "\\end{something}") + (goto-char pt2) + (should (equal (reftex-what-environment 1) `("something" . ,pt))) + (should (equal (reftex-what-environment t) `(("something" . ,pt) + ("equation" . 1)))) + (should (equal (reftex-what-environment t pt) `(("something" . ,pt)))) + (should (equal (reftex-what-environment '("equation")) + '("equation" . 1)))))) + +(ert-deftest reftex-roman-number-test () + "Test `reftex-roman-number'." + (let ((hindu-arabic '(1 2 4 9 14 1050)) + (roman '("I" "II" "IV" "IX" "XIV" "ML"))) + (while (and hindu-arabic roman) + (should (string= (reftex-roman-number (car hindu-arabic)) + (car roman))) + (pop roman) + (pop hindu-arabic)))) + +(ert-deftest reftex-parse-from-file-test () + "Test `reftex-parse-from-file'." + ;; Use file-truename to convert 8+3 aliases in $TEMP value on + ;; MS-Windows into their long file-name equivalents, which is + ;; necessary for the 'equal' and 'string=' comparisons below. This + ;; also resolves any symlinks, which cannot be bad for the same + ;; reason. (An alternative solution would be to use file-equal-p, + ;; but I'm too lazy to do that, as one of the tests compares a + ;; list.) + (let* ((temp-dir (file-truename (make-temp-file "reftex-parse" 'dir))) + (tex-file (expand-file-name "test.tex" temp-dir)) + (bib-file (expand-file-name "ref.bib" temp-dir))) + (with-temp-buffer + (insert +"\\begin{document} +\\section{test}\\label{sec:test} +\\subsection{subtest} + +\\begin{align*}\\label{eq:foo} + x &= y^2 +\\end{align*} + +\\bibliographystyle{plain} +\\bibliography{ref} +\\end{document}") + (write-region (point-min) (point-max) tex-file)) + (with-temp-buffer + (insert "test\n") + (write-region (point-min) (point-max) bib-file)) + (reftex-ensure-compiled-variables) + (let ((parsed (reftex-parse-from-file tex-file nil temp-dir))) + (should (equal (car parsed) `(eof ,tex-file))) + (pop parsed) + (while parsed + (let ((entry (pop parsed))) + (cond + ((eq (car entry) 'bib) + (should (string= (cadr entry) bib-file))) + ((eq (car entry) 'toc)) ;; ... + ((string= (car entry) "eq:foo")) + ((string= (car entry) "sec:test")) + ((eq (car entry) 'bof) + (should (string= (cadr entry) tex-file)) + (should (null parsed))) + (t (should-not t))))) + (delete-directory temp-dir 'recursive)))) + +;;; reftex-cite +(require 'reftex-cite) + +(ert-deftest reftex-parse-bibtex-entry-test () + "Test `reftex-parse-bibtex-entry'." + (let ((entry "@Book{Stallman12, + author = {Richard Stallman\net al.}, + title = {The Emacs Editor}, + publisher = {GNU Press}, + year = 2012, + edition = {17th}, + note = {Updated for Emacs Version 24.2} +}") + (check (function + (lambda (parsed) + (should (string= (reftex-get-bib-field "&key" parsed) + "Stallman12")) + (should (string= (reftex-get-bib-field "&type" parsed) + "book")) + (should (string= (reftex-get-bib-field "author" parsed) + "Richard Stallman et al.")) + (should (string= (reftex-get-bib-field "title" parsed) + "The Emacs Editor")) + (should (string= (reftex-get-bib-field "publisher" parsed) + "GNU Press")) + (should (string= (reftex-get-bib-field "year" parsed) + "2012")) + (should (string= (reftex-get-bib-field "edition" parsed) + "17th")) + (should (string= (reftex-get-bib-field "note" parsed) + "Updated for Emacs Version 24.2")))))) + (funcall check (reftex-parse-bibtex-entry entry)) + (with-temp-buffer + (insert entry) + (funcall check (reftex-parse-bibtex-entry nil (point-min) + (point-max)))))) + +(ert-deftest reftex-get-bib-names-test () + "Test `reftex-get-bib-names'." + (let ((entry (reftex-parse-bibtex-entry "@article{Foo123, + author = {Jane Roe and\tJohn Doe and W. Public}, +}"))) + (should (equal (reftex-get-bib-names "author" entry) + '("Jane Roe" "John Doe" "Public")))) + (let ((entry (reftex-parse-bibtex-entry "@article{Foo123, + editor = {Jane Roe and\tJohn Doe and W. Public}, +}"))) + (should (equal (reftex-get-bib-names "author" entry) + '("Jane Roe" "John Doe" "Public"))))) + +(ert-deftest reftex-format-citation-test () + "Test `reftex-format-citation'." + (let ((entry (reftex-parse-bibtex-entry +"@article{Foo13, + author = {Jane Roe and John Doe and Jane Q. Taxpayer}, + title = {Some Article}, + journal = {Some Journal}, + year = 2013, + pages = {1--333} +}"))) + (should (string= (reftex-format-citation entry nil) "\\cite{Foo13}")) + (should (string= (reftex-format-citation entry "%l:%A:%y:%t %j %P %a") + "Foo13:Jane Roe:2013:Some Article Some Journal 1 Jane Roe, John Doe \\& Jane Taxpayer")))) + + +;;; Autoload tests + +;; Test to check whether reftex autoloading mechanisms are working +;; correctly. +(ert-deftest reftex-autoload-auc () + "Tests to see whether reftex-auc has been autoloaded" + (should + (fboundp 'reftex-arg-label)) + (should + (autoloadp + (symbol-function + 'reftex-arg-label)))) + + +(provide 'reftex-tests) +;;; reftex-tests.el ends here. diff --cc test/lisp/textmodes/sgml-mode-tests.el index 4184e2c3802,00000000000..e1aa3e8857e mode 100644,000000..100644 --- a/test/lisp/textmodes/sgml-mode-tests.el +++ b/test/lisp/textmodes/sgml-mode-tests.el @@@ -1,135 -1,0 +1,135 @@@ +;;; sgml-mode-tests.el --- Tests for sgml-mode + - ;; Copyright (C) 2015-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2015-2017 Free Software Foundation, Inc. + +;; Author: Przemysław Wojnowski +;; Keywords: tests + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'sgml-mode) +(require 'ert) + +(defmacro sgml-with-content (content &rest body) + "Insert CONTENT into a temporary `sgml-mode' buffer and execute BODY on it. +The point is set to the beginning of the buffer." + `(with-temp-buffer + (sgml-mode) + (insert ,content) + (goto-char (point-min)) + ,@body)) + +;;; sgml-delete-tag + +(ert-deftest sgml-delete-tag-should-not-delete-tags-when-wrong-args () + "Don't delete tag, when number of tags to delete is not positive number." + (let ((content "

    Valar Morghulis

    ")) + (sgml-with-content + content + (sgml-delete-tag -1) + (should (string= content (buffer-string))) + (sgml-delete-tag 0) + (should (string= content (buffer-string)))))) + +(ert-deftest sgml-delete-tag-should-delete-tags-n-times () + ;; Delete only 1, when 1 available: + (sgml-with-content + "
    " + (sgml-delete-tag 1) + (should (string= "" (buffer-string)))) + ;; Delete from position on whitespaces before tag: + (sgml-with-content + " \t\n
    " + (sgml-delete-tag 1) + (should (string= "" (buffer-string)))) + ;; Delete from position on tag: + (sgml-with-content + "
    " + (goto-char 3) + (sgml-delete-tag 1) + (should (string= "" (buffer-string)))) + ;; Delete one by one: + (sgml-with-content + "

    You know nothing, Jon Snow.

    " + (sgml-delete-tag 1) + (should (string= "

    You know nothing, Jon Snow.

    " (buffer-string))) + (sgml-delete-tag 1) + (should (string= "You know nothing, Jon Snow." (buffer-string)))) + ;; Delete 2 at a time, when 2 available: + (sgml-with-content + "

    You know nothing, Jon Snow.

    " + (sgml-delete-tag 2) + (should (string= "You know nothing, Jon Snow." (buffer-string))))) + +(ert-deftest sgml-delete-tag-should-delete-unclosed-tag () + (sgml-with-content + "
    • Keep your stones connected.
    " + (goto-char 5) ; position on "li" tag + (sgml-delete-tag 1) + (should (string= "
      Keep your stones connected.
    " (buffer-string))))) + +(ert-deftest sgml-delete-tag-should-signal-error-for-malformed-tags () + (let ((content "

    Drakaris!

    ")) + ;; Delete outside tag: + (sgml-with-content + content + (sgml-delete-tag 1) + (should (string= "

    Drakaris!

    " (buffer-string)))) + ;; Delete inner tag: + (sgml-with-content + content + (goto-char 5) ; position the inner tag + (sgml-delete-tag 1) + (should (string= "

    Drakaris!

    " (buffer-string)))))) + +(ert-deftest sgml-delete-tag-should-signal-error-when-deleting-too-much () + (let ((content "Drakaris!")) + ;; No tags to delete: + (sgml-with-content + "Drakaris!" + (should-error (sgml-delete-tag 1) :type 'error) + (should (string= "Drakaris!" (buffer-string)))) + ;; Trying to delete 2 tags, when only 1 available: + (sgml-with-content + content + (should-error (sgml-delete-tag 2) :type 'error) + (should (string= "Drakaris!" (buffer-string)))) + ;; Trying to delete a tag, but not on/before a tag: + (sgml-with-content + content + (goto-char 7) ; D in Drakaris + (should-error (sgml-delete-tag 1) :type 'error) + (should (string= content (buffer-string)))) + ;; Trying to delete a tag from position outside tag: + (sgml-with-content + content + (goto-char (point-max)) + (should-error (sgml-delete-tag 1) :type 'error) + (should (string= content (buffer-string)))))) + +(ert-deftest sgml-delete-tag-bug-8203-should-not-delete-apostrophe () + :expected-result :failed + (sgml-with-content + "Winter is comin'" + (sgml-delete-tag 1) + (should (string= "Winter is comin'" (buffer-string))))) + +(provide 'sgml-mode-tests) +;;; sgml-mode-tests.el ends here diff --cc test/lisp/textmodes/tildify-tests.el index 8b50cf72868,00000000000..0a82b2521fb mode 100644,000000..100644 --- a/test/lisp/textmodes/tildify-tests.el +++ b/test/lisp/textmodes/tildify-tests.el @@@ -1,264 -1,0 +1,264 @@@ +;;; tildify-test.el --- ERT tests for tildify.el -*- lexical-binding: t -*- + - ;; Copyright (C) 2014-2016 Free Software Foundation, Inc. ++;; Copyright (C) 2014-2017 Free Software Foundation, Inc. + +;; Author: Michal Nazarewicz +;; Version: 4.5 +;; Keywords: text, TeX, SGML, wp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This package defines regression tests for the tildify package. + +;;; Code: + +(require 'ert) +(require 'tildify) + +(defun tildify-test--example-sentence (space) + "Return an example sentence with SPACE where hard space is required." + (concat "Lorem ipsum v" space "dolor sit amet, a" space + "consectetur adipiscing elit.")) + + +(defun tildify-test--example-html (sentence &optional with-nbsp is-xml) + "Return an example HTML code. +SENTENCE is placed where spaces should not be replaced with hard spaces, and +WITH-NBSP is placed where spaces should be replaced with hard spaces. If the +latter is missing, SENTENCE will be used in all placeholder positions. +If IS-XML is non-nil, 
     tag is not treated specially."
 +  (let ((with-nbsp (or with-nbsp sentence)))
 +    (concat "
    " with-nbsp "
    \n"
 +            "
    " (if is-xml with-nbsp sentence) "
    \n"
 +            "\n"
 +            "
    " with-nbsp "
    \n"
 +            "<" sentence ">\n")))
 +
 +
 +(defun tildify-test--test (modes input expected)
 +  "Test tildify running in MODES.
 +INPUT is the initial content of the buffer and EXPECTED is expected result
 +after `tildify-buffer' is run."
 +  (with-temp-buffer
 +    (setq-local buffer-file-coding-system 'utf-8)
 +    (dolist (mode modes)
 +      (erase-buffer)
 +      (funcall mode)
 +      (let ((header (concat "Testing `tildify-buffer' in "
 +                            (symbol-name mode) "\n")))
 +        (insert header input)
 +        (tildify-buffer t)
 +        (should (string-equal (concat header expected) (buffer-string))))
 +      (erase-buffer)
 +      (let ((header (concat "Testing `tildify-region' in "
 +                            (symbol-name mode) "\n")))
 +        (insert header input)
 +        (tildify-region (point-min) (point-max) t)
 +        (should (string-equal (concat header expected) (buffer-string)))))))
 +
 +(ert-deftest tildify-test-html ()
 +  "Tests tildification in an HTML document"
 +  (let* ((sentence (tildify-test--example-sentence " "))
 +         (with-nbsp (tildify-test--example-sentence " ")))
 +    (tildify-test--test '(html-mode sgml-mode)
 +                        (tildify-test--example-html sentence sentence)
 +                        (tildify-test--example-html sentence with-nbsp))))
 +
 +(ert-deftest tildify-test-xml ()
 +  "Tests tildification in an XML document"
 +  (let* ((sentence (tildify-test--example-sentence " "))
 +         (with-nbsp (tildify-test--example-sentence " ")))
 +    (tildify-test--test '(nxml-mode)
 +                        (tildify-test--example-html sentence sentence t)
 +                        (tildify-test--example-html sentence with-nbsp t))))
 +
 +
 +(defun tildify-test--example-tex (sentence &optional with-nbsp)
 +  "Return an example (La)Tex code.
 +SENTENCE is placed where spaces should not be replaced with hard spaces, and
 +WITH-NBSP is placed where spaces should be replaced with hard spaces.  If the
 +latter is missing, SENTENCE will be used in all placeholder positions."
 +  (let ((with-nbsp (or with-nbsp sentence)))
 +    (concat with-nbsp "\n"
 +            "\\begin{verbatim}\n" sentence "\n\\end{verbatim}\n"
 +            "\\verb#" sentence "#\n"
 +            "$$" sentence "$$\n"
 +            "$" sentence "$\n"
 +            "\\[" sentence "\\]\n"
 +            "\\v A % " sentence "\n"
 +            with-nbsp "\n")))
 +
 +(ert-deftest tildify-test-tex ()
 +  "Tests tildification in a (La)TeX document"
 +  (let* ((sentence (tildify-test--example-sentence " "))
 +         (with-nbsp (tildify-test--example-sentence "~")))
 +    (tildify-test--test '(tex-mode latex-mode plain-tex-mode)
 +                        (tildify-test--example-tex sentence sentence)
 +                        (tildify-test--example-tex sentence with-nbsp))))
 +
 +
 +(ert-deftest tildify-test-find-env-end-re-bug ()
 +    "Tests generation of end-regex using mix of indexes and strings"
 +  (with-temp-buffer
 +    (insert "foo whatever end-foo")
 +    (goto-char (point-min))
 +    (should (string-equal "end-foo"
 +                          (tildify--find-env "foo\\|bar"
 +                                             '(("foo\\|bar" . ("end-" 0))))))))
 +
 +
 +(ert-deftest tildify-test-find-env-group-index-bug ()
 +    "Tests generation of match-string indexes"
 +  (with-temp-buffer
 +    (let ((pairs '(("start-\\(foo\\|bar\\)" . ("end-" 1))
 +                   ("open-\\(foo\\|bar\\)" . ("close-" 1))))
 +          (beg-re "start-\\(foo\\|bar\\)\\|open-\\(foo\\|bar\\)"))
 +      (insert "open-foo whatever close-foo")
 +      (goto-char (point-min))
 +      (should (string-equal "close-foo" (tildify--find-env beg-re pairs))))))
 +
 +
 +(defmacro with-test-foreach (expected &rest body)
 +  "Helper macro for testing foreach functions.
 +BODY has access to pairs variable and called lambda."
 +  (declare (indent 1))
 +  (let ((got (make-symbol "got")))
 +    `(with-temp-buffer
 +       (insert "1 /- 2 -/ 3 V~ 4 ~ 5 /- 6 -/ 7")
 +       (let* ((pairs '(("/-" . "-/") ("V\\(.\\)" . (1))))
 +              (,got "")
 +              (called (lambda (s e)
 +                        (setq ,got (concat ,got (buffer-substring s e))))))
 +         (setq-local tildify-foreach-region-function
 +                     (apply-partially 'tildify-foreach-ignore-environments
 +                                      pairs))
 +         ,@body
 +         (should (string-equal ,expected ,got))))))
 +
 +(ert-deftest tildify-test-foreach-ignore-environments ()
 +    "Basic test of `tildify-foreach-ignore-environments'"
 +  (with-test-foreach "1  3  5  7"
 +    (tildify-foreach-ignore-environments pairs called (point-min) (point-max))))
 +
 +
 +(ert-deftest tildify-test-foreach-ignore-environments-early-return ()
 +    "Test whether `tildify-foreach-ignore-environments' returns early
 +The function must terminate as soon as callback returns nil."
 +  (with-test-foreach "1 "
 +    (tildify-foreach-ignore-environments
 +     pairs (lambda (start end) (funcall called start end) nil)
 +     (point-min) (point-max))))
 +
 +(ert-deftest tildify-test-foreach-region ()
 +    "Basic test of `tildify--foreach-region'"
 +  (with-test-foreach "1  3  5  7"
 +    (tildify--foreach-region called (point-min) (point-max))))
 +
 +(ert-deftest tildify-test-foreach-region-early-return ()
 +    "Test whether `tildify--foreach-ignore' returns early
 +The function must terminate as soon as callback returns nil."
 +  (with-test-foreach "1 "
 +    (tildify--foreach-region (lambda (start end) (funcall called start end) nil)
 +      (point-min) (point-max))))
 +
 +(ert-deftest tildify-test-foreach-region-limit-region ()
 +    "Test whether `tildify--foreach-ignore' limits callback to given region"
 +  (with-test-foreach "3 "
 +    (tildify--foreach-region called
 +      (+ (point-min) 10) (+ (point-min) 16))) ; start at "3" end past "4"
 +  (with-test-foreach "3  5"
 +    (tildify--foreach-region called
 +      (+ (point-min) 10) (+ (point-min) 20)))) ; start at "3" end past "5"
 +
 +
 +(defun tildify-space-test--test (modes nbsp env-open &optional set-space-string)
 +  (with-temp-buffer
 +    (setq-local buffer-file-coding-system 'utf-8)
 +    (dolist (mode modes)
 +      (funcall mode)
 +      (when set-space-string
 +        (setq-local tildify-space-string nbsp))
 +      (let ((header (concat "Testing `tildify-space' in "
 +                            (symbol-name mode) "\n")))
 +        ;; Replace space with hard space.
 +        (erase-buffer)
 +        (insert header "Lorem v ")
 +        (should (tildify-space))
 +        (should (string-equal (concat header "Lorem v" nbsp) (buffer-string)))
 +        ;; Inside and ignore environment, replacing does not happen.
 +        (erase-buffer)
 +        (insert header env-open "Lorem v ")
 +        (should (not (tildify-space)))
 +        (should (string-equal (concat header env-open "Lorem v ")
 +                              (buffer-string)))))))
 +
 +(ert-deftest tildify-space-test-html ()
 +  "Tests auto-tildification in an HTML document"
 +  (tildify-space-test--test '(html-mode sgml-mode) " " "
    "))
 +
 +(ert-deftest tildify-space-test-html-nbsp ()
 +  "Tests auto-tildification in an HTML document"
 +  (tildify-space-test--test '(html-mode sgml-mode) " " "
    " t))
 +
 +(ert-deftest tildify-space-test-xml ()
 +  "Tests auto-tildification in an XML document"
 +  (tildify-space-test--test '(nxml-mode) " " ""))
 +
 +(ert-deftest tildify-space-undo-test-html-nbsp ()
 +  "Tests auto-tildification in an HTML document"
 +  (tildify-space-undo-test--test '(html-mode sgml-mode) " " "
    " t))
 +
 +(ert-deftest tildify-space-undo-test-xml ()
 +  "Tests auto-tildification in an XML document"
 +  (tildify-space-undo-test--test '(nxml-mode) " " ".
 +
 +;;; Code:
 +
 +(require 'ert)
 +
 +(defvar thing-at-point-test-data
 +  '(("http://1.gnu.org" 1  url "http://1.gnu.org")
 +    ("http://2.gnu.org" 6 url "http://2.gnu.org")
 +    ("http://3.gnu.org" 19 url "http://3.gnu.org")
 +    ("https://4.gnu.org" 1  url "https://4.gnu.org")
 +    ("A geo URI (geo:3.14159,-2.71828)." 12 url "geo:3.14159,-2.71828")
 +    ("Visit http://5.gnu.org now." 5 url nil)
 +    ("Visit http://6.gnu.org now." 7 url "http://6.gnu.org")
 +    ("Visit http://7.gnu.org now." 22 url "http://7.gnu.org")
 +    ("Visit http://8.gnu.org now." 22 url "http://8.gnu.org")
 +    ("Visit http://9.gnu.org now." 24 url nil)
 +    ;; Invalid URIs
 +    ("<<<<" 2 url nil)
 +    ("<>" 1 url nil)
 +    ("" 1 url nil)
 +    ("http://" 1 url nil)
 +    ;; Invalid schema
 +    ("foo://www.gnu.org" 1 url nil)
 +    ("foohttp://www.gnu.org" 1 url nil)
 +    ;; Non alphanumeric characters can be found in URIs
 +    ("ftp://example.net/~foo!;#bar=baz&goo=bob" 3 url "ftp://example.net/~foo!;#bar=baz&goo=bob")
 +    ("bzr+ssh://user@example.net:5/a%20d,5" 34 url "bzr+ssh://user@example.net:5/a%20d,5")
 +    ;;  markup
 +    ("Url: ..." 8 url "foo://1.example.com")
 +    ("Url: ..." 30 url "foo://2.example.com")
 +    ("Url: ..." 20 url "foo://www.gnu.org/a bc")
 +    ;; Hack used by thing-at-point: drop punctuation at end of URI.
 +    ("Go to http://www.gnu.org, for details" 7 url "http://www.gnu.org")
 +    ("Go to http://www.gnu.org." 24 url "http://www.gnu.org")
 +    ;; Standard URI delimiters
 +    ("Go to \"http://10.gnu.org\"." 8 url "http://10.gnu.org")
 +    ("Go to \"http://11.gnu.org/\"." 26 url "http://11.gnu.org/")
 +    ("Go to  now." 8 url "http://12.gnu.org")
 +    ("Go to  now." 24 url "http://13.gnu.org")
 +    ;; Parenthesis handling (non-standard)
 +    ("http://example.com/a(b)c" 21 url "http://example.com/a(b)c")
 +    ("http://example.com/a(b)" 21 url "http://example.com/a(b)")
 +    ("(http://example.com/abc)" 2 url "http://example.com/abc")
 +    ("This (http://example.com/a(b))" 7 url "http://example.com/a(b)")
 +    ("This (http://example.com/a(b))" 30 url "http://example.com/a(b)")
 +    ("This (http://example.com/a(b))" 5 url nil)
 +    ("http://example.com/ab)c" 4 url "http://example.com/ab)c")
 +    ;; URL markup, lacking schema
 +    ("" 1 url "mailto:foo@example.com")
 +    ("" 1 url "ftp://ftp.example.net/abc/"))
 +  "List of thing-at-point tests.
 +Each list element should have the form
 +
 +  (STRING POS THING RESULT)
 +
 +where STRING is a string of buffer contents, POS is the value of
 +point, THING is a symbol argument for `thing-at-point', and
 +RESULT should be the result of calling `thing-at-point' from that
 +position to retrieve THING.")
 +
 +(ert-deftest thing-at-point-tests ()
 +  "Test the file-local variables implementation."
 +  (dolist (test thing-at-point-test-data)
 +    (with-temp-buffer
 +      (insert (nth 0 test))
 +      (goto-char (nth 1 test))
 +      (should (equal (thing-at-point (nth 2 test)) (nth 3 test))))))
 +
 +;; These tests reflect the actual behavior of
 +;; `thing-at-point-bounds-of-list-at-point'.
 +(ert-deftest thing-at-point-bug24627 ()
 +  "Test for http://debbugs.gnu.org/24627 ."
 +  (let ((string-result '(("(a \"b\" c)" . (a "b" c))
 +                         (";(a \"b\" c)")
 +                         ("(a \"b\" c\n)" . (a "b" c))
 +                         ("\"(a b c)\"")
 +                         ("(a ;(b c d)\ne)" . (a e))
 +                         ("(foo\n(a ;(b c d)\ne) bar)" . (a e))
 +                         ("(foo\na ;(b c d)\ne bar)" . (foo a e bar))
 +                         ("(foo\n(a \"(b c d)\"\ne) bar)" . (a "(b c d)" e))
 +                         ("(b\n(a ;(foo c d)\ne) bar)" . (a e))
 +                         ("(princ \"(a b c)\")" . (princ "(a b c)"))
 +                         ("(defun foo ()\n  \"Test function.\"\n  ;;(a b)\n  nil)" . (defun foo nil "Test function." nil))))
 +        (file
 +         (expand-file-name "lisp/thingatpt.el" source-directory))
 +        buf)
 +    ;; Test for `thing-at-point'.
 +    (when (file-exists-p file)
 +      (unwind-protect
 +          (progn
 +            (setq buf (find-file file))
 +            (goto-char (point-max))
 +            (forward-line -1)
 +            (should-not (thing-at-point 'list)))
 +        (kill-buffer buf)))
 +    ;; Tests for `list-at-point'.
 +    (dolist (str-res string-result)
 +      (with-temp-buffer
 +        (emacs-lisp-mode)
 +        (insert (car str-res))
 +        (re-search-backward "\\((a\\|^a\\)")
 +        (should (equal (list-at-point)
 +                       (cdr str-res)))))))
 +
 +;;; thingatpt.el ends here
diff --cc test/lisp/url/url-expand-tests.el
index 6d1d54d4ffc,00000000000..2debbdeb753
mode 100644,000000..100644
--- a/test/lisp/url/url-expand-tests.el
+++ b/test/lisp/url/url-expand-tests.el
@@@ -1,105 -1,0 +1,105 @@@
 +;;; url-expand-tests.el --- Test suite for relative URI/URL resolution.
 +
- ;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2012-2017 Free Software Foundation, Inc.
 +
 +;; Author: Alain Schneble 
 +;; Version: 1.0
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +
 +;; Test cases covering URI reference resolution as described in RFC3986,
 +;; section 5. Reference Resolution and especially the relative resolution
 +;; rules specified in section 5.2. Relative Resolution.
 +
 +;; Each test calls `url-expand-file-name', typically with a relative
 +;; reference URI and a base URI as string and compares the result (Actual)
 +;; against a manually specified URI (Expected)
 +
 +;;; Code:
 +
 +(require 'url-expand)
 +(require 'ert)
 +
 +(ert-deftest url-expand-file-name/relative-resolution-normal-examples ()
 +  "RFC 3986, Section 5.4 Reference Resolution Examples / Section 5.4.1. Normal Examples"
 +  (should (equal (url-expand-file-name "g:h"     "http://a/b/c/d;p?q") "g:h"))
 +  (should (equal (url-expand-file-name "g"       "http://a/b/c/d;p?q") "http://a/b/c/g"))
 +  (should (equal (url-expand-file-name "./g"     "http://a/b/c/d;p?q") "http://a/b/c/g"))
 +  (should (equal (url-expand-file-name "g/"      "http://a/b/c/d;p?q") "http://a/b/c/g/"))
 +  (should (equal (url-expand-file-name "/g"      "http://a/b/c/d;p?q") "http://a/g"))
 +  (should (equal (url-expand-file-name "//g"     "http://a/b/c/d;p?q") "http://g"))
 +  (should (equal (url-expand-file-name "?y"      "http://a/b/c/d;p?q") "http://a/b/c/d;p?y"))
 +  (should (equal (url-expand-file-name "g?y"     "http://a/b/c/d;p?q") "http://a/b/c/g?y"))
 +  (should (equal (url-expand-file-name "#s"      "http://a/b/c/d;p?q") "http://a/b/c/d;p?q#s"))
 +  (should (equal (url-expand-file-name "g#s"     "http://a/b/c/d;p?q") "http://a/b/c/g#s"))
 +  (should (equal (url-expand-file-name "g?y#s"   "http://a/b/c/d;p?q") "http://a/b/c/g?y#s"))
 +  (should (equal (url-expand-file-name ";x"      "http://a/b/c/d;p?q") "http://a/b/c/;x"))
 +  (should (equal (url-expand-file-name "g;x"     "http://a/b/c/d;p?q") "http://a/b/c/g;x"))
 +  (should (equal (url-expand-file-name "g;x?y#s" "http://a/b/c/d;p?q") "http://a/b/c/g;x?y#s"))
 +  (should (equal (url-expand-file-name ""        "http://a/b/c/d;p?q") "http://a/b/c/d;p?q"))
 +  (should (equal (url-expand-file-name "."       "http://a/b/c/d;p?q") "http://a/b/c/"))
 +  (should (equal (url-expand-file-name "./"      "http://a/b/c/d;p?q") "http://a/b/c/"))
 +  (should (equal (url-expand-file-name ".."      "http://a/b/c/d;p?q") "http://a/b/"))
 +  (should (equal (url-expand-file-name "../"     "http://a/b/c/d;p?q") "http://a/b/"))
 +  (should (equal (url-expand-file-name "../g"    "http://a/b/c/d;p?q") "http://a/b/g"))
 +  (should (equal (url-expand-file-name "../.."   "http://a/b/c/d;p?q") "http://a/"))
 +  (should (equal (url-expand-file-name "../../"  "http://a/b/c/d;p?q") "http://a/"))
 +  (should (equal (url-expand-file-name "../../g" "http://a/b/c/d;p?q") "http://a/g")))
 +
 +(ert-deftest url-expand-file-name/relative-resolution-absolute-examples ()
 +  "RFC 3986, Section 5.4 Reference Resolution Examples / Section 5.4.2. Abnormal Examples"
 +  (should (equal (url-expand-file-name "../../../g"    "http://a/b/c/d;p?q") "http://a/g"))
 +  (should (equal (url-expand-file-name "../../../../g" "http://a/b/c/d;p?q") "http://a/g"))
 +
 +  (should (equal (url-expand-file-name "/./g"          "http://a/b/c/d;p?q") "http://a/g"))
 +  (should (equal (url-expand-file-name "/../g"         "http://a/b/c/d;p?q") "http://a/g"))
 +  (should (equal (url-expand-file-name "g."            "http://a/b/c/d;p?q") "http://a/b/c/g."))
 +  (should (equal (url-expand-file-name ".g"            "http://a/b/c/d;p?q") "http://a/b/c/.g"))
 +  (should (equal (url-expand-file-name "g.."           "http://a/b/c/d;p?q") "http://a/b/c/g.."))
 +  (should (equal (url-expand-file-name "..g"           "http://a/b/c/d;p?q") "http://a/b/c/..g"))
 +
 +  (should (equal (url-expand-file-name "./../g"        "http://a/b/c/d;p?q") "http://a/b/g"))
 +  (should (equal (url-expand-file-name "./g/."         "http://a/b/c/d;p?q") "http://a/b/c/g/"))
 +  (should (equal (url-expand-file-name "g/./h"         "http://a/b/c/d;p?q") "http://a/b/c/g/h"))
 +  (should (equal (url-expand-file-name "g/../h"        "http://a/b/c/d;p?q") "http://a/b/c/h"))
 +  (should (equal (url-expand-file-name "g;x=1/./y"     "http://a/b/c/d;p?q") "http://a/b/c/g;x=1/y"))
 +  (should (equal (url-expand-file-name "g;x=1/../y"    "http://a/b/c/d;p?q") "http://a/b/c/y"))
 +
 +  (should (equal (url-expand-file-name "g?y/./x"       "http://a/b/c/d;p?q") "http://a/b/c/g?y/./x"))
 +  (should (equal (url-expand-file-name "g?y/../x"      "http://a/b/c/d;p?q") "http://a/b/c/g?y/../x"))
 +  (should (equal (url-expand-file-name "g#s/./x"       "http://a/b/c/d;p?q") "http://a/b/c/g#s/./x"))
 +  (should (equal (url-expand-file-name "g#s/../x"      "http://a/b/c/d;p?q") "http://a/b/c/g#s/../x"))
 +
 +  (should (equal (url-expand-file-name "http:g"        "http://a/b/c/d;p?q") "http:g")) ; for strict parsers
 +  )
 +
 +(ert-deftest url-expand-file-name/relative-resolution-additional-examples ()
 +  "Reference Resolution Examples / Arbitrary Examples"
 +  (should (equal (url-expand-file-name "" "http://host/foobar") "http://host/foobar"))
 +  (should (equal (url-expand-file-name "?y"      "http://a/b/c/d") "http://a/b/c/d?y"))
 +  (should (equal (url-expand-file-name "?y"      "http://a/b/c/d/") "http://a/b/c/d/?y"))
 +  (should (equal (url-expand-file-name "?y#fragment"      "http://a/b/c/d;p?q") "http://a/b/c/d;p?y#fragment"))
 +  (should (equal (url-expand-file-name "#bar" "http://host") "http://host#bar"))
 +  (should (equal (url-expand-file-name "#bar" "http://host/") "http://host/#bar"))
 +  (should (equal (url-expand-file-name "#bar" "http://host/foo") "http://host/foo#bar"))
 +  (should (equal (url-expand-file-name "foo#bar" "http://host/foobar") "http://host/foo#bar"))
 +  (should (equal (url-expand-file-name "foo#bar" "http://host/foobar/") "http://host/foobar/foo#bar")))
 +
 +(provide 'url-expand-tests)
 +
 +;;; url-expand-tests.el ends here
diff --cc test/lisp/url/url-future-tests.el
index 87298cc1b96,00000000000..64d045219ba
mode 100644,000000..100644
--- a/test/lisp/url/url-future-tests.el
+++ b/test/lisp/url/url-future-tests.el
@@@ -1,57 -1,0 +1,57 @@@
 +;;; url-future-tests.el --- Test suite for url-future.
 +
- ;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2011-2017 Free Software Foundation, Inc.
 +
 +;; Author: Teodor Zlatanov 
 +;; Keywords: data
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Code:
 +
 +(require 'ert)
 +(require 'url-future)
 +
 +(ert-deftest url-future-tests ()
 +  (let* (saver
 +         (text "running future")
 +         (good (make-url-future :value (lambda () (format text))
 +                                :callback (lambda (f) (set 'saver f))))
 +         (bad (make-url-future :value (lambda () (/ 1 0))
 +                               :errorback (lambda (&rest d) (set 'saver d))))
 +         (tocancel (make-url-future :value (lambda () (/ 1 0))
 +                                    :callback (lambda (f) (set 'saver f))
 +                                    :errorback (lambda (&rest d)
 +                                                 (set 'saver d)))))
 +    (should (equal good (url-future-call good)))
 +    (should (equal good saver))
 +    (should (equal text (url-future-value good)))
 +    (should (url-future-completed-p good))
 +    (should-error (url-future-call good))
 +    (setq saver nil)
 +    (should (equal bad (url-future-call bad)))
 +    (should-error (url-future-call bad))
 +    (should (equal saver (list bad '(arith-error))))
 +    (should (url-future-errored-p bad))
 +    (setq saver nil)
 +    (should (equal (url-future-cancel tocancel) tocancel))
 +    (should-error (url-future-call tocancel))
 +    (should (null saver))
 +    (should (url-future-cancelled-p tocancel))))
 +
 +(provide 'url-future-tests)
 +
 +;;; url-future-tests.el ends here
diff --cc test/lisp/url/url-parse-tests.el
index 77c5320e351,00000000000..05da7280aa2
mode 100644,000000..100644
--- a/test/lisp/url/url-parse-tests.el
+++ b/test/lisp/url/url-parse-tests.el
@@@ -1,167 -1,0 +1,167 @@@
 +;;; url-parse-tests.el --- Test suite for URI/URL parsing.
 +
- ;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2012-2017 Free Software Foundation, Inc.
 +
 +;; Author: Alain Schneble 
 +;; Version: 1.0
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +
 +;; Test cases covering generic URI syntax as described in RFC3986,
 +;; section 3. Syntax Components and 4. Usage. See also appendix
 +;; A. Collected ABNF for URI, as the example given here are all
 +;; productions of this grammar.
 +
 +;; Each tests parses a given URI string - whether relative or absolute -
 +;; using `url-generic-parse-url' and compares the constructed
 +;; URL-struct (Actual) against a manually `url-parse-make-urlobj'-
 +;; constructed URL-struct (Expected).
 +
 +;;; Code:
 +
 +(require 'url-parse)
 +(require 'ert)
 +
 +(ert-deftest url-generic-parse-url/generic-uri-examples ()
 +  "RFC 3986, section 1.1.2. Examples / Example illustrating several URI schemes and variations in their common syntax components"
 +  (should (equal (url-generic-parse-url "ftp://ftp.is.co.za/rfc/rfc1808.txt") (url-parse-make-urlobj "ftp" nil nil "ftp.is.co.za" nil "/rfc/rfc1808.txt" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://www.ietf.org/rfc/rfc2396.txt") (url-parse-make-urlobj "http" nil nil "www.ietf.org" nil "/rfc/rfc2396.txt" nil nil t)))
 +  (should (equal (url-generic-parse-url "ldap://[2001:db8::7]/c=GB?objectClass?one") (url-parse-make-urlobj "ldap" nil nil "[2001:db8::7]" nil "/c=GB?objectClass?one" nil nil t)))
 +  (should (equal (url-generic-parse-url "mailto:John.Doe@example.com") (url-parse-make-urlobj "mailto" nil nil nil nil "John.Doe@example.com" nil nil nil)))
 +  (should (equal (url-generic-parse-url "news:comp.infosystems.www.servers.unix") (url-parse-make-urlobj "news" nil nil nil nil "comp.infosystems.www.servers.unix" nil nil nil)))
 +  (should (equal (url-generic-parse-url "tel:+1-816-555-1212") (url-parse-make-urlobj "tel" nil nil nil nil "+1-816-555-1212" nil nil nil)))
 +  (should (equal (url-generic-parse-url "telnet://192.0.2.16:80/") (url-parse-make-urlobj "telnet" nil nil "192.0.2.16" 80 "/" nil nil t)))
 +  (should (equal (url-generic-parse-url "urn:oasis:names:specification:docbook:dtd:xml:4.1.2") (url-parse-make-urlobj "urn" nil nil nil nil "oasis:names:specification:docbook:dtd:xml:4.1.2" nil nil nil))))
 +
 +(ert-deftest url-generic-parse-url/generic-uri ()
 +  "RFC 3986, section 3. Syntax Components / generic URI syntax"
 +  ;; empty path
 +  (should (equal (url-generic-parse-url "http://host#") (url-parse-make-urlobj "http" nil nil "host" nil "" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host?#") (url-parse-make-urlobj "http" nil nil "host" nil "?" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host?query#") (url-parse-make-urlobj "http" nil nil "host" nil "?query" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host?#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "?" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host?query#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "?query" "fragment" nil t)))
 +  ;; absolute path /
 +  (should (equal (url-generic-parse-url "http://host/#") (url-parse-make-urlobj "http" nil nil "host" nil "/" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/?#") (url-parse-make-urlobj "http" nil nil "host" nil "/?" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/?query#") (url-parse-make-urlobj "http" nil nil "host" nil "/?query" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/?#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/?" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/?query#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/?query" "fragment" nil t)))
 +  ;; absolute path /foo
 +  (should (equal (url-generic-parse-url "http://host/foo#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo?#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo?" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo?query#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo?query" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo?#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo?" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo?query#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo?query" "fragment" nil t)))
 +  ;; absolute path /foo/
 +  (should (equal (url-generic-parse-url "http://host/foo/#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/?#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/?" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/?query#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/?query" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/?#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/?" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/?query#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/?query" "fragment" nil t)))
 +  ;; absolute path /foo/bar
 +  (should (equal (url-generic-parse-url "http://host/foo/bar#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar?#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar?" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar?query#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar?query" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar?#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar?" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar?query#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar?query" "fragment" nil t)))
 +  ;; absolute path /foo/bar/
 +  (should (equal (url-generic-parse-url "http://host/foo/bar/#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar/#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar/?#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/?" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar/?query#") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/?query" "" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar/?#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/?" "fragment" nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar/?query#fragment") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/?query" "fragment" nil t)))
 +  ;; for more examples of URIs without fragments, see tests covering section 4.3. Absolute URI
 +  )
 +
 +(ert-deftest url-generic-parse-url/network-path-reference ()
 +  "RFC 3986, section 4.2. Relative Reference / network-path reference: a relative reference that begins with two slash characters"
 +  (should (equal (url-generic-parse-url "//host") (url-parse-make-urlobj nil nil nil "host" nil "" nil nil t)))
 +  (should (equal (url-generic-parse-url "//host/") (url-parse-make-urlobj nil nil nil "host" nil "/" nil nil t)))
 +  (should (equal (url-generic-parse-url "//host/foo") (url-parse-make-urlobj nil nil nil "host" nil "/foo" nil nil t)))
 +  (should (equal (url-generic-parse-url "//host/foo/bar") (url-parse-make-urlobj nil nil nil "host" nil "/foo/bar" nil nil t)))
 +  (should (equal (url-generic-parse-url "//host/foo/bar/") (url-parse-make-urlobj nil nil nil "host" nil "/foo/bar/" nil nil t))))
 +
 +(ert-deftest url-generic-parse-url/absolute-path-reference ()
 +  "RFC 3986, section 4.2. Relative Reference / absolute-path reference: a relative reference that begins with a single slash character"
 +  (should (equal (url-generic-parse-url "/") (url-parse-make-urlobj nil nil nil nil nil "/" nil nil nil)))
 +  (should (equal (url-generic-parse-url "/foo") (url-parse-make-urlobj nil nil nil nil nil "/foo" nil nil nil)))
 +  (should (equal (url-generic-parse-url "/foo/bar") (url-parse-make-urlobj nil nil nil nil nil "/foo/bar" nil nil nil)))
 +  (should (equal (url-generic-parse-url "/foo/bar/") (url-parse-make-urlobj nil nil nil nil nil "/foo/bar/" nil nil nil)))
 +  (should (equal (url-generic-parse-url "/foo/bar#") (url-parse-make-urlobj nil nil nil nil nil "/foo/bar" "" nil nil)))
 +  (should (equal (url-generic-parse-url "/foo/bar/#") (url-parse-make-urlobj nil nil nil nil nil "/foo/bar/" "" nil nil))))
 +
 +(ert-deftest url-generic-parse-url/relative-path-reference ()
 +  "RFC 3986, section 4.2. Relative Reference / relative-path reference: a relative reference that does not begin with a slash character"
 +  (should (equal (url-generic-parse-url "foo") (url-parse-make-urlobj nil nil nil nil nil "foo" nil nil nil)))
 +  (should (equal (url-generic-parse-url "foo/bar") (url-parse-make-urlobj nil nil nil nil nil "foo/bar" nil nil nil)))
 +  (should (equal (url-generic-parse-url "foo/bar/") (url-parse-make-urlobj nil nil nil nil nil "foo/bar/" nil nil nil)))
 +  (should (equal (url-generic-parse-url "./foo") (url-parse-make-urlobj nil nil nil nil nil "./foo" nil nil nil)))
 +  (should (equal (url-generic-parse-url "./foo/bar") (url-parse-make-urlobj nil nil nil nil nil "./foo/bar" nil nil nil)))
 +  (should (equal (url-generic-parse-url "./foo/bar/") (url-parse-make-urlobj nil nil nil nil nil "./foo/bar/" nil nil nil)))
 +  (should (equal (url-generic-parse-url "../foo") (url-parse-make-urlobj nil nil nil nil nil "../foo" nil nil nil)))
 +  (should (equal (url-generic-parse-url "../foo/bar") (url-parse-make-urlobj nil nil nil nil nil "../foo/bar" nil nil nil)))
 +  (should (equal (url-generic-parse-url "../foo/bar/") (url-parse-make-urlobj nil nil nil nil nil "../foo/bar/" nil nil nil)))
 +  (should (equal (url-generic-parse-url "./this:that") (url-parse-make-urlobj nil nil nil nil nil "./this:that" nil nil nil)))
 +  ;; for more examples of relative-path references, see tests covering section 4.4. Same-Document Reference
 +  )
 +
 +(ert-deftest url-generic-parse-url/absolute-uri ()
 +  "RFC 3986, section 4.3. Absolute URI / absolute URI: absolute form of a URI without a fragment identifier"
 +  ;; empty path
 +  (should (equal (url-generic-parse-url "http://host") (url-parse-make-urlobj "http" nil nil "host" nil "" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host?") (url-parse-make-urlobj "http" nil nil "host" nil "?" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host?query") (url-parse-make-urlobj "http" nil nil "host" nil "?query" nil nil t)))
 +  ;; absolute path /
 +  (should (equal (url-generic-parse-url "http://host/") (url-parse-make-urlobj "http" nil nil "host" nil "/" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host/?") (url-parse-make-urlobj "http" nil nil "host" nil "/?" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host/?query") (url-parse-make-urlobj "http" nil nil "host" nil "/?query" nil nil t)))
 +  ;; absolute path /foo
 +  (should (equal (url-generic-parse-url "http://host/foo") (url-parse-make-urlobj "http" nil nil "host" nil "/foo" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo?") (url-parse-make-urlobj "http" nil nil "host" nil "/foo?" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo?query") (url-parse-make-urlobj "http" nil nil "host" nil "/foo?query" nil nil t)))
 +  ;; absolute path /foo/
 +  (should (equal (url-generic-parse-url "http://host/foo/") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/?") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/?" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/?query") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/?query" nil nil t)))
 +  ;; absolute path /foo/bar
 +  (should (equal (url-generic-parse-url "http://host/foo/bar") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar?") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar?" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar?query") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar?query" nil nil t)))
 +  ;; absolute path /foo/bar/
 +  (should (equal (url-generic-parse-url "http://host/foo/bar/") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar/?") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/?" nil nil t)))
 +  (should (equal (url-generic-parse-url "http://host/foo/bar/?query") (url-parse-make-urlobj "http" nil nil "host" nil "/foo/bar/?query" nil nil t)))
 +  ;; example mentioned in RFC3986, section 5.4. Reference Resolution Examples
 +  (should (equal (url-generic-parse-url "http://a/b/c/d;p?q") (url-parse-make-urlobj "http" nil nil "a" nil "/b/c/d;p?q" nil nil t))))
 +
 +(ert-deftest url-generic-parse-url/same-document-reference ()
 +  "RFC 3986, section 4.4. Same-Document Reference / same-document reference: empty or number sign (\"#\") followed by a fragment identifier"
 +  (should (equal (url-generic-parse-url "") (url-parse-make-urlobj nil nil nil nil nil "" nil nil nil)))
 +  (should (equal (url-generic-parse-url "#") (url-parse-make-urlobj nil nil nil nil nil "" "" nil nil)))
 +  (should (equal (url-generic-parse-url "#foo") (url-parse-make-urlobj nil nil nil nil nil "" "foo" nil nil))))
 +
 +(provide 'url-parse-tests)
 +
 +;;; url-parse-tests.el ends here
diff --cc test/lisp/url/url-util-tests.el
index 2f1de5103d6,00000000000..c3375890c01
mode 100644,000000..100644
--- a/test/lisp/url/url-util-tests.el
+++ b/test/lisp/url/url-util-tests.el
@@@ -1,51 -1,0 +1,51 @@@
 +;;; url-util-tests.el --- Test suite for url-util.
 +
- ;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2012-2017 Free Software Foundation, Inc.
 +
 +;; Author: Teodor Zlatanov 
 +;; Keywords: data
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Code:
 +
 +(require 'ert)
 +(require 'url-util)
 +
 +(ert-deftest url-util-tests ()
 +  (let ((tests
 +         '(("key1=val1&key2=val2&key3=val1&key3=val2&key4&key5"
 +            ((key1 val1) (key2 "val2") (key3 val1 val2) (key4) (key5 "")))
 +           ("key1=val1;key2=val2;key3=val1;key3=val2;key4;key5"
 +            ((key1 "val1") (key2 val2) (key3 val1 val2) ("key4") (key5 "")) t)
 +           ("key1=val1;key2=val2;key3=val1;key3=val2;key4=;key5="
 +            ((key1 val1) (key2 val2) ("key3" val1 val2) (key4) (key5 "")) t t)))
 +        test)
 +    (while tests
 +      (setq test (car tests)
 +            tests (cdr tests))
 +      (should (equal (apply 'url-build-query-string (cdr test)) (car test)))))
 +  (should (equal (url-parse-query-string
 +                  "key1=val1&key2=val2&key3=val1&key3=val2&key4=&key5")
 +                 '(("key5" "")
 +                   ("key4" "")
 +                   ("key3" "val2" "val1")
 +                   ("key2" "val2")
 +                   ("key1" "val1")))))
 +
 +(provide 'url-util-tests)
 +
 +;;; url-util-tests.el ends here
diff --cc test/lisp/vc/add-log-tests.el
index 71be5a9eadc,00000000000..3e7bc7fdf0d
mode 100644,000000..100644
--- a/test/lisp/vc/add-log-tests.el
+++ b/test/lisp/vc/add-log-tests.el
@@@ -1,85 -1,0 +1,85 @@@
 +;;; add-log-tests.el --- Test suite for add-log.
 +
- ;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
 +
 +;; Author: Masatake YAMATO 
 +;; Keywords: vc tools
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Code:
 +
 +(require 'ert)
 +(require 'add-log)
 +
 +(defmacro add-log-current-defun-deftest (name doc major-mode
 +					      content marker expected-defun)
 +  "Generate an ert test for mode-own `add-log-current-defun-function'.
 +Run `add-log-current-defun' at the point where MARKER specifies in a
 +buffer which content is CONTENT under MAJOR-MODE. Then it compares the
 +result with EXPECTED-DEFUN."
 +  (let ((xname (intern (concat "add-log-current-defun-test-"
 +			       (symbol-name name)
 +			       ))))
 +    `(ert-deftest ,xname ()
 +	 ,doc
 +       (with-temp-buffer
 +	 (insert ,content)
 +	 (goto-char (point-min))
 +	 (funcall ',major-mode)
 +	 (should (equal (when (search-forward ,marker nil t)
 +			  (replace-match "" nil t)
 +			  (add-log-current-defun))
 +			,expected-defun))))))
 +
 +(add-log-current-defun-deftest
 + sh-func1
 + "Test sh-current-defun-name can find function."
 + sh-mode "
 +function foo
 +{
 +	><
 +}" "><" "foo")
 +
 +(add-log-current-defun-deftest
 + sh-func2
 + "Test sh-current-defun-name can find function."
 + sh-mode "
 +foo()
 +{
 +	><
 +}" "><" "foo")
 +
 +(add-log-current-defun-deftest
 + sh-func3
 + "Test sh-current-defun-name can find function."
 + sh-mode "
 +function foo()
 +{
 +	><
 +}" "><" "foo")
 +
 +(add-log-current-defun-deftest
 + sh-var
 + "Test sh-current-defun-name can find variable definition."
 + sh-mode "
 +PATH=a:/ab:/usr/abc
 +DIR=/pr><" "DIR")
 +
 +(provide 'add-log-tests)
 +
 +;;; add-log-tests.el ends here
diff --cc test/lisp/vc/vc-bzr-tests.el
index f27e6588cf2,00000000000..fc7d8f8283f
mode 100644,000000..100644
--- a/test/lisp/vc/vc-bzr-tests.el
+++ b/test/lisp/vc/vc-bzr-tests.el
@@@ -1,140 -1,0 +1,140 @@@
 +;;; vc-bzr.el --- tests for vc/vc-bzr.el
 +
- ;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2011-2017 Free Software Foundation, Inc.
 +
 +;; Author: Glenn Morris 
 +;; Maintainer: emacs-devel@gnu.org
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +
 +;;; Code:
 +
 +(require 'ert)
 +(require 'vc-bzr)
 +(require 'vc-dir)
 +
 +(ert-deftest vc-bzr-test-bug9726 ()
 +  "Test for http://debbugs.gnu.org/9726 ."
 +  (skip-unless (executable-find vc-bzr-program))
 +  ;; Bzr wants to access HOME, e.g. to write ~/.bzr.log.
 +  ;; This is a problem on hydra, where HOME is non-existent.
 +  ;; You can disable logging with BZR_LOG=/dev/null, but then some
 +  ;; commands (eg `bzr status') want to access ~/.bazaar, and will
 +  ;; abort if they cannot.  I could not figure out how to stop bzr
 +  ;; doing that, so just give it a temporary homedir for the duration.
 +  ;; http://bugs.launchpad.net/bzr/+bug/137407 ?
 +  (let* ((homedir (make-temp-file "vc-bzr-test" t))
 +         (bzrdir (expand-file-name "bzr" homedir))
 +         (ignored-dir (progn
 +                        (make-directory bzrdir)
 +                        (expand-file-name "ignored-dir" bzrdir)))
 +         (default-directory (file-name-as-directory bzrdir))
 +         (process-environment (cons (format "BZR_HOME=%s" homedir)
 +                                    process-environment)))
 +    (unwind-protect
 +        (progn
 +          (make-directory ignored-dir)
 +          (with-temp-buffer
 +            (insert (file-name-nondirectory ignored-dir))
 +            (write-region nil nil (expand-file-name ".bzrignore" bzrdir)
 +                          nil 'silent))
 +          (call-process vc-bzr-program nil nil nil "init")
 +          (call-process vc-bzr-program nil nil nil "add")
 +          (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1")
 +          (with-temp-buffer
 +            (insert "unregistered file")
 +            (write-region nil nil (expand-file-name "testfile2" ignored-dir)
 +                          nil 'silent))
 +          (vc-dir ignored-dir)
 +          (while (vc-dir-busy)
 +            (sit-for 0.1))
 +          ;; FIXME better to explicitly test for error from process sentinel.
 +          (with-current-buffer "*vc-dir*"
 +            (goto-char (point-min))
 +            (should (search-forward "unregistered" nil t))))
 +      (delete-directory homedir t))))
 +
 +;; Not specific to bzr.
 +(ert-deftest vc-bzr-test-bug9781 ()
 +  "Test for http://debbugs.gnu.org/9781 ."
 +  (skip-unless (executable-find vc-bzr-program))
 +  (let* ((homedir (make-temp-file "vc-bzr-test" t))
 +         (bzrdir (expand-file-name "bzr" homedir))
 +         (subdir (progn
 +                   (make-directory bzrdir)
 +                   (expand-file-name "subdir" bzrdir)))
 +         (file (expand-file-name "file" bzrdir))
 +         (default-directory (file-name-as-directory bzrdir))
 +         (process-environment (cons (format "BZR_HOME=%s" homedir)
 +                                    process-environment)))
 +    (unwind-protect
 +        (progn
 +          (call-process vc-bzr-program nil nil nil "init")
 +          (make-directory subdir)
 +          (with-temp-buffer
 +            (insert "text")
 +            (write-region nil nil file nil 'silent)
 +            (write-region nil nil (expand-file-name "subfile" subdir)
 +                          nil 'silent))
 +          (call-process vc-bzr-program nil nil nil "add")
 +          (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1")
 +          (call-process vc-bzr-program nil nil nil "remove" subdir)
 +          (with-temp-buffer
 +            (insert "different text")
 +            (write-region nil nil file nil 'silent))
 +          (vc-dir bzrdir)
 +          (while (vc-dir-busy)
 +            (sit-for 0.1))
 +          (vc-dir-mark-all-files t)
 +          (cl-letf (((symbol-function 'y-or-n-p) (lambda (_) t)))
 +            (vc-next-action nil))
 +          (should (get-buffer "*vc-log*")))
 +      (delete-directory homedir t))))
 +
 +;; http://lists.gnu.org/archive/html/help-gnu-emacs/2012-04/msg00145.html
 +(ert-deftest vc-bzr-test-faulty-bzr-autoloads ()
 +  "Test we can generate autoloads in a bzr directory when bzr is faulty."
 +  (skip-unless (executable-find vc-bzr-program))
 +  (let* ((homedir (make-temp-file "vc-bzr-test" t))
 +         (bzrdir (expand-file-name "bzr" homedir))
 +         (file (progn
 +                 (make-directory bzrdir)
 +                 (expand-file-name "foo.el" bzrdir)))
 +         (default-directory (file-name-as-directory bzrdir))
 +         (generated-autoload-file (expand-file-name "loaddefs.el" bzrdir))
 +         (process-environment (cons (format "BZR_HOME=%s" homedir)
 +                                    process-environment)))
 +    (unwind-protect
 +        (progn
 +          (call-process vc-bzr-program nil nil nil "init")
 +          (with-temp-buffer
 +            (insert ";;;###autoload
 +\(defun foo () \"foo\" (interactive) (message \"foo!\"))")
 +            (write-region nil nil file nil 'silent))
 +          (call-process vc-bzr-program nil nil nil "add")
 +          (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1")
 +          ;; Deleting dirstate ensures both that vc-bzr's status heuristic
 +          ;; fails, so it has to call the external bzr status, and
 +          ;; causes bzr status to fail.  This simulates a broken bzr
 +          ;; installation.
 +          (delete-file ".bzr/checkout/dirstate")
 +          (should (progn (update-directory-autoloads default-directory)
 +                         t)))
 +      (delete-directory homedir t))))
 +
 +;;; vc-bzr.el ends here
diff --cc test/lisp/vc/vc-hg.el
index ba966598c4d,00000000000..8e4c9739e08
mode 100644,000000..100644
--- a/test/lisp/vc/vc-hg.el
+++ b/test/lisp/vc/vc-hg.el
@@@ -1,58 -1,0 +1,58 @@@
 +;;; vc-hg.el --- tests for vc/vc-hg.el
 +
- ;; Copyright (C) 2016 Free Software Foundation, Inc.
++;; Copyright (C) 2016-2017 Free Software Foundation, Inc.
 +
 +;; Author: Dmitry Gutov 
 +;; Maintainer: emacs-devel@gnu.org
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +
 +;;; Code:
 +
 +(require 'vc-hg)
 +(require 'vc-annotate)
 +
 +(ert-deftest vc-hg-annotate-extract-revision-at-line-with-filename ()
 +  ;; with filename
 +  (with-temp-buffer
 +    (save-excursion (insert "215 2007-06-20 CONTENTS:"))
 +    (should (equal (vc-hg-annotate-extract-revision-at-line)
 +                   (cons
 +                    "215"
 +                    (expand-file-name "CONTENTS"))))))
 +
 +(ert-deftest vc-hg-annotate-extract-revision-at-line-with-user ()
 +  (with-temp-buffer
 +    (save-excursion (insert " gerv 107217 2012-09-17:"))
 +    (should (equal (vc-hg-annotate-extract-revision-at-line)
 +                   "107217"))))
 +
 +(ert-deftest vc-hg-annotate-extract-revision-at-line-with-both ()
 +  (with-temp-buffer
 +    (save-excursion (insert "philringnalda 218075 2014-11-28   CLOBBER:"))
 +    (should (equal (vc-hg-annotate-extract-revision-at-line)
 +                   (cons
 +                    "218075"
 +                    (expand-file-name "CLOBBER"))))))
 +
 +(ert-deftest vc-hg-annotate-time ()
 +  (with-temp-buffer
 +    (save-excursion (insert "philringnalda 218075 2014-11-28 CLOBBER:"))
 +    (should (floatp (vc-hg-annotate-time)))))
 +
 +;;; vc-hg.el ends here
diff --cc test/lisp/vc/vc-tests.el
index b54a45dd323,00000000000..ad4399db032
mode 100644,000000..100644
--- a/test/lisp/vc/vc-tests.el
+++ b/test/lisp/vc/vc-tests.el
@@@ -1,610 -1,0 +1,610 @@@
 +;;; vc-tests.el --- Tests of different backends of vc.el
 +
- ;; Copyright (C) 2014-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2014-2017 Free Software Foundation, Inc.
 +
 +;; Author: Michael Albinus 
 +
 +;; This program is free software: you can redistribute it and/or
 +;; modify it under the terms of the GNU General Public License as
 +;; published by the Free Software Foundation, either version 3 of the
 +;; License, or (at your option) any later version.
 +;;
 +;; This program is distributed in the hope that it will be useful, but
 +;; WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 +;; General Public License for more details.
 +;;
 +;; You should have received a copy of the GNU General Public License
 +;; along with this program.  If not, see `http://www.gnu.org/licenses/'.
 +
 +;;; Commentary:
 +
 +;; For every supported VC on the machine, different test cases are
 +;; generated automatically.
 +
 +;; Functions to be tested (see Commentary of vc.el).  Mandatory
 +;; functions are marked with `*', optional functions are marked with `-':
 +
 +;; BACKEND PROPERTIES
 +;;
 +;; * revision-granularity                                       DONE
 +
 +;; STATE-QUERYING FUNCTIONS
 +;;
 +;; * registered (file)                                          DONE
 +;; * state (file)                                               DONE
 +;; - dir-status (dir update-function)
 +;; - dir-status-files (dir files default-state update-function)
 +;; - dir-extra-headers (dir)
 +;; - dir-printer (fileinfo)
 +;; - status-fileinfo-extra (file)
 +;; * working-revision (file)                                    DONE
 +;; - latest-on-branch-p (file)
 +;; * checkout-model (files)                                     DONE
 +;; - mode-line-string (file)
 +
 +;; STATE-CHANGING FUNCTIONS
 +;;
 +;; * create-repo (backend)                                      DONE
 +;; * register (files &optional comment)                         DONE
 +;; - responsible-p (file)
 +;; - receive-file (file rev)
 +;; - unregister (file)                                          DONE
 +;; * checkin (files comment)
 +;; * find-revision (file rev buffer)
 +;; * checkout (file &optional rev)
 +;; * revert (file &optional contents-done)
 +;; - rollback (files)
 +;; - merge-file (file rev1 rev2)
 +;; - merge-branch ()
 +;; - merge-news (file)
 +;; - pull (prompt)
 +;; - steal-lock (file &optional revision)
 +;; - modify-change-comment (files rev comment)
 +;; - mark-resolved (files)
 +;; - find-admin-dir (file)
 +
 +;; HISTORY FUNCTIONS
 +;;
 +;; * print-log (files buffer &optional shortlog start-revision limit)
 +;; * log-outgoing (backend remote-location)
 +;; * log-incoming (backend remote-location)
 +;; - log-view-mode ()
 +;; - show-log-entry (revision)
 +;; - comment-history (file)
 +;; - update-changelog (files)
 +;; * diff (files &optional async rev1 rev2 buffer)
 +;; - revision-completion-table (files)
 +;; - annotate-command (file buf &optional rev)
 +;; - annotate-time ()
 +;; - annotate-current-time ()
 +;; - annotate-extract-revision-at-line ()
 +;; - region-history (FILE BUFFER LFROM LTO)
 +;; - region-history-mode ()
 +
 +;; TAG SYSTEM
 +;;
 +;; - create-tag (dir name branchp)
 +;; - retrieve-tag (dir name update)
 +
 +;; MISCELLANEOUS
 +;;
 +;; - make-version-backups-p (file)
 +;; - root (file)
 +;; - ignore (file &optional directory)
 +;; - ignore-completion-table
 +;; - previous-revision (file rev)
 +;; - next-revision (file rev)
 +;; - log-edit-mode ()
 +;; - check-headers ()
 +;; - delete-file (file)
 +;; - rename-file (old new)
 +;; - find-file-hook ()
 +;; - extra-menu ()
 +;; - extra-dir-menu ()
 +;; - conflicted-files (dir)
 +
 +;;; Code:
 +
 +(require 'ert)
 +(require 'vc)
 +
 +(declare-function w32-application-type "w32proc")
 +
 +;; The working horses.
 +
 +(defvar vc-test--cleanup-hook nil
 +  "Functions for cleanup at the end of an ert test.
 +Don't set it globally, the functions shall be let-bound.")
 +
 +(defun vc-test--revision-granularity-function (backend)
 +  "Run the `vc-revision-granularity' backend function."
 +  (vc-call-backend backend 'revision-granularity))
 +
 +(defun vc-test--create-repo-function (backend)
 +  "Run the `vc-create-repo' backend function.
 +For backends which dont support it, it is emulated."
 +
 +  (cond
 +   ((eq backend 'CVS)
 +    (let ((tmp-dir
 +	   (expand-file-name
 +	    (make-temp-name "vc-test") temporary-file-directory)))
 +      (make-directory (expand-file-name "module" tmp-dir) 'parents)
 +      (make-directory (expand-file-name "CVSROOT" tmp-dir) 'parents)
 +      (if (not (fboundp 'w32-application-type))
 +          (shell-command-to-string (format "cvs -Q -d:local:%s co module"
 +                                           tmp-dir))
 +        (let ((cvs-prog (executable-find "cvs"))
 +              (tdir tmp-dir))
 +          ;; If CVS executable is an MSYS program, reformat the file
 +          ;; name of TMP-DIR to have the /d/foo/bar form supported by
 +          ;; MSYS programs.  (FIXME: What about Cygwin cvs.exe?)
 +          (if (eq (w32-application-type cvs-prog) 'msys)
 +              (setq tdir
 +                    (concat "/" (substring tmp-dir 0 1) (substring tmp-dir 2))))
 +          (shell-command-to-string (format "cvs -Q -d:local:%s co module"
 +                                           tdir))))
 +      (rename-file "module/CVS" default-directory)
 +      (delete-directory "module" 'recursive)
 +      ;; We must cleanup the "remote" CVS repo as well.
 +      (add-hook 'vc-test--cleanup-hook
 +		`(lambda () (delete-directory ,tmp-dir 'recursive)))))
 +
 +   ((eq backend 'Arch)
 +    (let ((archive-name (format "%s--%s" user-mail-address (random))))
 +      (when (string-match
 +	     "no arch user id set" (shell-command-to-string "tla my-id"))
 +	(shell-command-to-string
 +	 (format "tla my-id \"<%s>\"" user-mail-address)))
 +      (shell-command-to-string
 +       (format "tla make-archive %s %s" archive-name default-directory))
 +      (shell-command-to-string
 +       (format "tla my-default-archive %s" archive-name))))
 +
 +   ((eq backend 'Mtn)
 +    (let ((archive-name "foo.mtn"))
 +      (shell-command-to-string
 +       (format
 +	"mtn db init --db=%s"
 +	(expand-file-name archive-name default-directory)))
 +      (shell-command-to-string
 +       (format "mtn --db=%s --branch=foo setup ." archive-name))))
 +
 +   (t (vc-create-repo backend))))
 +
 +(defun vc-test--create-repo (backend)
 +  "Create a test repository in `default-directory', a temporary directory."
 +
 +  (let ((vc-handled-backends `(,backend))
 +	(default-directory
 +	  (file-name-as-directory
 +	   (expand-file-name
 +	    (make-temp-name "vc-test") temporary-file-directory)))
 +	vc-test--cleanup-hook)
 +
 +    (unwind-protect
 +	(progn
 +	  ;; Cleanup.
 +	  (add-hook
 +	   'vc-test--cleanup-hook
 +	   `(lambda () (delete-directory ,default-directory 'recursive)))
 +
 +	  ;; Check the revision granularity.
 +	  (should (memq (vc-test--revision-granularity-function backend)
 +			'(file repository)))
 +
 +	  ;; Create empty repository.
 +	  (make-directory default-directory)
 +	  (should (file-directory-p default-directory))
 +	  (vc-test--create-repo-function backend)
 +	  (should (eq (vc-responsible-backend default-directory) backend)))
 +
 +      ;; Save exit.
 +      (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
 +
 +;; FIXME: Why isn't there `vc-unregister'?
 +(defun vc-test--unregister-function (backend file)
 +  "Run the `vc-unregister' backend function.
 +For backends which don't support it, `vc-not-supported' is signaled."
 +  ;; CVS, SVN, SCCS, SRC and Mtn are not supported, and will signal
 +  ;; `vc-not-supported'.
 +  (prog1
 +      (vc-call-backend backend 'unregister file)
 +    (vc-file-clearprops file)))
 +
 +(defmacro vc-test--run-maybe-unsupported-function (func &rest args)
 +  "Run FUNC with ARGS as arguments.
 +Catch the `vc-not-supported' error."
 +  `(let (err)
 +    (condition-case err
 +        (funcall ,func ,@args)
 +      (vc-not-supported 'vc-not-supported)
 +      (t (signal (car err) (cdr err))))))
 +
 +(defun vc-test--register (backend)
 +  "Register and unregister a file.
 +This checks also `vc-backend' and `vc-responsible-backend'."
 +
 +  (let ((vc-handled-backends `(,backend))
 +	(default-directory
 +	  (file-name-as-directory
 +	   (expand-file-name
 +	    (make-temp-name "vc-test") temporary-file-directory)))
 +	vc-test--cleanup-hook)
 +
 +    (unwind-protect
 +	(progn
 +	  ;; Cleanup.
 +	  (add-hook
 +	   'vc-test--cleanup-hook
 +	   `(lambda () (delete-directory ,default-directory 'recursive)))
 +
 +	  ;; Create empty repository.
 +	  (make-directory default-directory)
 +	  (vc-test--create-repo-function backend)
 +          ;; For file oriented backends CVS, RCS and SVN the backend is
 +          ;; returned, and the directory is registered already.
 +          (should (if (vc-backend default-directory)
 +                      (vc-registered default-directory)
 +                    (not (vc-registered default-directory))))
 +          (should (eq (vc-responsible-backend default-directory) backend))
 +
 +	  (let ((tmp-name1 (expand-file-name "foo" default-directory))
 +		(tmp-name2 "bla"))
 +	    ;; Register files.  Check for it.
 +	    (write-region "foo" nil tmp-name1 nil 'nomessage)
 +	    (should (file-exists-p tmp-name1))
 +            (should-not (vc-backend tmp-name1))
 +            (should (eq (vc-responsible-backend tmp-name1) backend))
 +	    (should-not (vc-registered tmp-name1))
 +
 +	    (write-region "bla" nil tmp-name2 nil 'nomessage)
 +	    (should (file-exists-p tmp-name2))
 +            (should-not (vc-backend tmp-name2))
 +            (should (eq (vc-responsible-backend tmp-name2) backend))
 +	    (should-not (vc-registered tmp-name2))
 +
 +	    (vc-register (list backend (list tmp-name1 tmp-name2)))
 +	    (should (file-exists-p tmp-name1))
 +            (should (eq (vc-backend tmp-name1) backend))
 +            (should (eq (vc-responsible-backend tmp-name1) backend))
 +	    (should (vc-registered tmp-name1))
 +
 +	    (should (file-exists-p tmp-name2))
 +            (should (eq (vc-backend tmp-name2) backend))
 +            (should (eq (vc-responsible-backend tmp-name2) backend))
 +	    (should (vc-registered tmp-name2))
 +
 +            ;; `vc-backend' accepts also a list of files,
 +            ;; `vc-responsible-backend' doesn't.
 +            (should (vc-backend (list tmp-name1 tmp-name2)))
 +
 +	    ;; Unregister the files.
 +            (unless (eq (vc-test--run-maybe-unsupported-function
 +			 'vc-test--unregister-function backend tmp-name1)
 +			'vc-not-supported)
 +              (should-not (vc-backend tmp-name1))
 +              (should-not (vc-registered tmp-name1)))
 +            (unless (eq (vc-test--run-maybe-unsupported-function
 +			 'vc-test--unregister-function backend tmp-name2)
 +			'vc-not-supported)
 +              (should-not (vc-backend tmp-name2))
 +              (should-not (vc-registered tmp-name2)))
 +
 +            ;; The files shall still exist.
 +	    (should (file-exists-p tmp-name1))
 +	    (should (file-exists-p tmp-name2))))
 +
 +      ;; Save exit.
 +      (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
 +
 +(defun vc-test--state (backend)
 +  "Check the different states of a file."
 +
 +  (let ((vc-handled-backends `(,backend))
 +	(default-directory
 +	  (file-name-as-directory
 +	   (expand-file-name
 +	    (make-temp-name "vc-test") temporary-file-directory)))
 +	vc-test--cleanup-hook)
 +
 +    (unwind-protect
 +	(progn
 +	  ;; Cleanup.
 +	  (add-hook
 +	   'vc-test--cleanup-hook
 +	   `(lambda () (delete-directory ,default-directory 'recursive)))
 +
 +	  ;; Create empty repository.
 +	  (make-directory default-directory)
 +	  (vc-test--create-repo-function backend)
 +
 +	  (let ((tmp-name (expand-file-name "foo" default-directory)))
 +	    ;; Check state of a nonexistent file.
 +
 +            (message "vc-state2 %s" (vc-state tmp-name))
 +	    (should (null (vc-state tmp-name)))
 +
 +	    ;; Write a new file.  Check state.
 +	    (write-region "foo" nil tmp-name nil 'nomessage)
 +
 +            (message "vc-state3 %s" (vc-state tmp-name))
 +	    (should (null (vc-state tmp-name)))
 +
 +	    ;; Register a file.  Check state.
 +	    (vc-register
 +	     (list backend (list (file-name-nondirectory tmp-name))))
 +
 +            ;; FIXME: nil is definitely wrong.
 +	    ;; nil: SRC
 +            ;; added: Bzr CVS Git Hg Mtn SVN
 +	    ;; up-to-date: RCS SCCS
 +            (message "vc-state4 %s" (vc-state tmp-name))
 +	    (should (memq (vc-state tmp-name) '(nil added up-to-date)))
 +
 +	    ;; Unregister the file.  Check state.
 +            (if (eq (vc-test--run-maybe-unsupported-function
 +                     'vc-test--unregister-function backend tmp-name)
 +                    'vc-not-supported)
 +                (message "vc-state5 unsupported")
 +              ;; nil: Bzr Git Hg RCS
 +              ;; unsupported: CVS Mtn SCCS SRC SVN
 +              (message "vc-state5 %s" (vc-state tmp-name))
 +              (should (null (vc-state tmp-name))))))
 +
 +      ;; Save exit.
 +      (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
 +
 +(defun vc-test--working-revision (backend)
 +  "Check the working revision of a repository."
 +
 +  (let ((vc-handled-backends `(,backend))
 +	(default-directory
 +	  (file-name-as-directory
 +	   (expand-file-name
 +	    (make-temp-name "vc-test") temporary-file-directory)))
 +	vc-test--cleanup-hook)
 +
 +    (unwind-protect
 +	(progn
 +	  ;; Cleanup.
 +	  (add-hook
 +	   'vc-test--cleanup-hook
 +	   `(lambda () (delete-directory ,default-directory 'recursive)))
 +
 +	  ;; Create empty repository.  Check working revision of
 +	  ;; repository, should be nil.
 +	  (make-directory default-directory)
 +	  (vc-test--create-repo-function backend)
 +
 +          ;; FIXME: Is the value for SVN correct?
 +	  ;; nil: Bzr CVS Git Hg Mtn RCS SCCS SRC
 +	  ;; "0": SVN
 +          (message
 +           "vc-working-revision1 %s" (vc-working-revision default-directory))
 +          (should (member (vc-working-revision default-directory) '(nil "0")))
 +
 +	  (let ((tmp-name (expand-file-name "foo" default-directory)))
 +	    ;; Check initial working revision, should be nil until
 +            ;; it's registered.
 +
 +            (message "vc-working-revision2 %s" (vc-working-revision tmp-name))
 +            (should-not (vc-working-revision tmp-name))
 +
 +	    ;; Write a new file.  Check working revision.
 +	    (write-region "foo" nil tmp-name nil 'nomessage)
 +
 +            (message "vc-working-revision3 %s" (vc-working-revision tmp-name))
 +            (should-not (vc-working-revision tmp-name))
 +
 +	    ;; Register a file.  Check working revision.
 +	    (vc-register
 +	     (list backend (list (file-name-nondirectory tmp-name))))
 +
 +            ;; XXX: nil is fine, at least in Git's case, because
 +	    ;; `vc-register' only makes the file `added' in this case.
 +	    ;; nil: Git Mtn
 +	    ;; "0": Bzr CVS Hg SRC SVN
 +	    ;; "1.1": RCS SCCS
 +            (message "vc-working-revision4 %s" (vc-working-revision tmp-name))
 +            (should (member (vc-working-revision tmp-name) '(nil "0" "1.1")))
 +
 +            ;; TODO: Call `vc-checkin', and check the resulting
 +            ;; working revision.  None of the return values should be
 +            ;; nil then.
 +
 +	    ;; Unregister the file.  Check working revision.
 +            (if (eq (vc-test--run-maybe-unsupported-function
 +                     'vc-test--unregister-function backend tmp-name)
 +                    'vc-not-supported)
 +                (message "vc-working-revision5 unsupported")
 +              ;; nil: Bzr Git Hg RCS
 +              ;; unsupported: CVS Mtn SCCS SRC SVN
 +              (message "vc-working-revision5 %s" (vc-working-revision tmp-name))
 +              (should-not (vc-working-revision tmp-name)))))
 +
 +      ;; Save exit.
 +      (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
 +
 +(defun vc-test--checkout-model (backend)
 +  "Check the checkout model of a repository."
 +
 +  (let ((vc-handled-backends `(,backend))
 +	(default-directory
 +	  (file-name-as-directory
 +	   (expand-file-name
 +	    (make-temp-name "vc-test") temporary-file-directory)))
 +	vc-test--cleanup-hook)
 +
 +    (unwind-protect
 +	(progn
 +	  ;; Cleanup.
 +	  (add-hook
 +	   'vc-test--cleanup-hook
 +	   `(lambda () (delete-directory ,default-directory 'recursive)))
 +
 +	  ;; Create empty repository.  Check repository checkout model.
 +	  (make-directory default-directory)
 +	  (vc-test--create-repo-function backend)
 +
 +	  ;; Surprisingly, none of the backends returns 'announce.
 +          ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
 +          ;; locking: RCS SCCS
 +          (message
 +           "vc-checkout-model1 %s"
 +           (vc-checkout-model backend default-directory))
 +          (should (memq (vc-checkout-model backend default-directory)
 +			'(announce implicit locking)))
 +
 +	  (let ((tmp-name (expand-file-name "foo" default-directory)))
 +	    ;; Check checkout model of a nonexistent file.
 +
 +	    ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
 +	    ;; locking: RCS SCCS
 +            (message
 +             "vc-checkout-model2 %s" (vc-checkout-model backend tmp-name))
 +	    (should (memq (vc-checkout-model backend tmp-name)
 +			  '(announce implicit locking)))
 +
 +	    ;; Write a new file.  Check checkout model.
 +	    (write-region "foo" nil tmp-name nil 'nomessage)
 +
 +	    ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
 +	    ;; locking: RCS SCCS
 +            (message
 +             "vc-checkout-model3 %s" (vc-checkout-model backend tmp-name))
 +	    (should (memq (vc-checkout-model backend tmp-name)
 +			  '(announce implicit locking)))
 +
 +	    ;; Register a file.  Check checkout model.
 +	    (vc-register
 +	     (list backend (list (file-name-nondirectory tmp-name))))
 +
 +	    ;; implicit: Bzr CVS Git Hg Mtn SRC SVN
 +	    ;; locking: RCS SCCS
 +            (message
 +             "vc-checkout-model4 %s" (vc-checkout-model backend tmp-name))
 +	    (should (memq (vc-checkout-model backend tmp-name)
 +			  '(announce implicit locking)))
 +
 +	    ;; Unregister the file.  Check checkout model.
 +            (if (eq (vc-test--run-maybe-unsupported-function
 +                     'vc-test--unregister-function backend tmp-name)
 +                    'vc-not-supported)
 +                (message "vc-checkout-model5 unsupported")
 +              ;; implicit: Bzr Git Hg
 +              ;; locking: RCS
 +              ;; unsupported: CVS Mtn SCCS SRC SVN
 +              (message
 +               "vc-checkout-model5 %s" (vc-checkout-model backend tmp-name))
 +              (should (memq (vc-checkout-model backend tmp-name)
 +                            '(announce implicit locking))))))
 +
 +      ;; Save exit.
 +      (ignore-errors (run-hooks 'vc-test--cleanup-hook)))))
 +
 +;; Create the test cases.
 +
 +(defun vc-test--rcs-enabled ()
 +  (executable-find "rcs"))
 +
 +(defun vc-test--cvs-enabled ()
 +  (executable-find "cvs"))
 +
 +(defvar vc-svn-program)
 +(defun vc-test--svn-enabled ()
 +  (executable-find vc-svn-program))
 +
 +(defun vc-test--sccs-enabled ()
 +  (executable-find "sccs"))
 +
 +(defvar vc-src-program)
 +(defun vc-test--src-enabled ()
 +  (executable-find vc-src-program))
 +
 +(defvar vc-bzr-program)
 +(defun vc-test--bzr-enabled ()
 +  (executable-find vc-bzr-program))
 +
 +(defvar vc-git-program)
 +(defun vc-test--git-enabled ()
 +  (executable-find vc-git-program))
 +
 +(defvar vc-hg-program)
 +(defun vc-test--hg-enabled ()
 +  (executable-find vc-hg-program))
 +
 +(defvar vc-mtn-program)
 +(defun vc-test--mtn-enabled ()
 +  (executable-find vc-mtn-program))
 +
 +;; Obsoleted.
 +(defvar vc-arch-program)
 +(defun vc-test--arch-enabled ()
 +  (executable-find vc-arch-program))
 +
 +;; Create the test cases.
 +(dolist (backend vc-handled-backends)
 +  (let ((backend-string (downcase (symbol-name backend))))
 +    (require (intern (format "vc-%s" backend-string)))
 +    (eval
 +     ;; Check, whether the backend is supported.
 +     `(when (funcall ',(intern (format "vc-test--%s-enabled" backend-string)))
 +
 +	(ert-deftest
 +	    ,(intern (format "vc-test-%s00-create-repo" backend-string)) ()
 +	  ,(format "Check `vc-create-repo' for the %s backend."
 +		   backend-string)
 +	  (vc-test--create-repo ',backend))
 +
 +	(ert-deftest
 +	    ,(intern (format "vc-test-%s01-register" backend-string)) ()
 +	  ,(format
 +	    "Check `vc-register' and `vc-registered' for the %s backend."
 +	    backend-string)
 +	  (skip-unless
 +	   (ert-test-passed-p
 +	    (ert-test-most-recent-result
 +	     (ert-get-test
 +	      ',(intern
 +		 (format "vc-test-%s00-create-repo" backend-string))))))
 +	  (vc-test--register ',backend))
 +
 +	(ert-deftest
 +	    ,(intern (format "vc-test-%s02-state" backend-string)) ()
 +	  ,(format "Check `vc-state' for the %s backend." backend-string)
 +	  (skip-unless
 +	   (ert-test-passed-p
 +	    (ert-test-most-recent-result
 +	     (ert-get-test
 +	      ',(intern
 +		 (format "vc-test-%s01-register" backend-string))))))
 +	  (vc-test--state ',backend))
 +
 +	(ert-deftest
 +	    ,(intern (format "vc-test-%s03-working-revision" backend-string)) ()
 +	  ,(format "Check `vc-working-revision' for the %s backend."
 +		   backend-string)
 +	  (skip-unless
 +	   (ert-test-passed-p
 +	    (ert-test-most-recent-result
 +	     (ert-get-test
 +	      ',(intern
 +		 (format "vc-test-%s01-register" backend-string))))))
 +	  (vc-test--working-revision ',backend))
 +
 +	(ert-deftest
 +	    ,(intern (format "vc-test-%s04-checkout-model" backend-string)) ()
 +	  ,(format "Check `vc-checkout-model' for the %s backend."
 +		   backend-string)
 +	  (skip-unless
 +	   (ert-test-passed-p
 +	    (ert-test-most-recent-result
 +	     (ert-get-test
 +	      ',(intern
 +		 (format "vc-test-%s01-register" backend-string))))))
 +	  (vc-test--checkout-model ',backend))))))
 +
 +(provide 'vc-tests)
 +;;; vc-tests.el ends here
diff --cc test/lisp/xml-tests.el
index 488d2c6f920,00000000000..0f2182a6a75
mode 100644,000000..100644
--- a/test/lisp/xml-tests.el
+++ b/test/lisp/xml-tests.el
@@@ -1,141 -1,0 +1,141 @@@
 +;;; xml-parse-tests.el --- Test suite for XML parsing.
 +
- ;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2012-2017 Free Software Foundation, Inc.
 +
 +;; Author: Chong Yidong 
 +;; Keywords:       internal
 +;; Human-Keywords: internal
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +
 +;; Type M-x test-xml-parse RET to generate the test buffer.
 +
 +;;; Code:
 +
 +(require 'ert)
 +(require 'xml)
 +
 +(defvar xml-parse-tests--data
 +  `(;; General entity substitution
 +    ("]>&ent;;" .
 +     ((foo ((a . "b")) (bar nil "AbC;"))))
 +    ("&amp;&apos;'<>"" .
 +     ((foo () "&''<>\"")))
 +    ;; Parameter entity substitution
 +    ("]>&ent;;" .
 +     ((foo ((a . "b")) (bar nil "AbC;"))))
 +    ;; Tricky parameter entity substitution (like XML spec Appendix D)
 +    ("' > %xx; ]>A&ent;C" .
 +     ((foo () "AbC")))
 +    ;; Bug#7172
 +    (" ]>" .
 +     ((foo ())))
 +    ;; Entities referencing entities, in character data
 +    ("]>&abc;" .
 +     ((foo () "aBc")))
 +    ;; Entities referencing entities, in attribute values
 +    ("]>1" .
 +     ((foo ((a . "-aBc-")) "1")))
 +    ;; Character references must be treated as character data
 +    ("AT&T;" . ((foo () "AT&T;")))
 +    ("&amp;" . ((foo () "&")))
 +    ("&amp;" . ((foo () "&")))
 +    ;; Unusual but valid XML names [5]
 +    ("<ÀÖØö.3·-‿⁀󯿿>abc" . ((,(intern "ÀÖØö.3·-‿⁀󯿿") () "abc")))
 +    ("<:>abc" . ((,(intern ":") () "abc"))))
 +  "Alist of XML strings and their expected parse trees.")
 +
 +(defvar xml-parse-tests--bad-data
 +  '(;; XML bomb in content
 +    "]>&lol2;"
 +    ;; XML bomb in attribute value
 +    "]>!"
 +    ;; Non-terminating DTD
 +    ""
 +    "asdf"
 +    "asdf&abc;"
 +    ;; Invalid XML names
 +    "<0foo>abc"
 +    "<‿foo>abc"
 +    "abc"
 +    ;; Two root tags
 +    ""
 +    ;; Bug#16344
 +    "< /x>"
 +    "< b/>")
 +  "List of XML strings that should signal an error in the parser")
 +
 +(defvar xml-parse-tests--qnames
 +  '( ;; Test data for name expansion
 +    ("/calendar/events/HTTP/1.1 200 OK"
 +    ;; Result with qnames as cons
 +    ((("DAV:" . "multistatus")
 +      ((("http://www.w3.org/2000/xmlns/" . "D") . "DAV:"))
 +      (("DAV:" . "response") nil (("DAV:" . "href") nil "/calendar/events/")
 +       (("DAV:" . "propstat") nil (("DAV:" . "status") nil "HTTP/1.1 200 OK")))))
 +    ;; Result with qnames as symbols
 +    ((DAV:multistatus
 +      ((("http://www.w3.org/2000/xmlns/" . "D") . "DAV:"))
 +      (DAV:response nil (DAV:href nil "/calendar/events/")
 +		    (DAV:propstat nil (DAV:status nil "HTTP/1.1 200 OK"))))))
 +    ("hi there"
 +     ((("FOOBAR:" . "something") nil "hi there"))
 +     ((FOOBAR:something nil "hi there"))))
 +  "List of strings which are parsed using namespace expansion.
 +Parser is called with and without 'symbol-qnames argument.")
 +
 +(ert-deftest xml-parse-tests ()
 +  "Test XML parsing."
 +  (with-temp-buffer
 +    (dolist (test xml-parse-tests--data)
 +      (erase-buffer)
 +      (insert (car test))
 +      (should (equal (cdr test) (xml-parse-region))))
 +    (let ((xml-entity-expansion-limit 50))
 +      (dolist (test xml-parse-tests--bad-data)
 +	(erase-buffer)
 +	(insert test)
 +	(should-error (xml-parse-region))))
 +    (let ((testdata (car xml-parse-tests--qnames)))
 +      (erase-buffer)
 +      (insert (car testdata))
 +      (should (equal (nth 1 testdata)
 +		     (xml-parse-region nil nil nil nil t)))
 +      (should (equal (nth 2 testdata)
 +		     (xml-parse-region nil nil nil nil 'symbol-qnames))))
 +    (let ((testdata (nth 1 xml-parse-tests--qnames)))
 +      (erase-buffer)
 +      (insert (car testdata))
 +      ;; Provide additional namespace-URI mapping
 +      (should (equal (nth 1 testdata)
 +		     (xml-parse-region
 +		      nil nil nil nil
 +		      (append xml-default-ns
 +			      '(("F" . "FOOBAR:"))))))
 +      (should (equal (nth 2 testdata)
 +		     (xml-parse-region
 +		      nil nil nil nil
 +		      (cons 'symbol-qnames
 +			    (append xml-default-ns
 +				    '(("F" . "FOOBAR:"))))))))))
 +
 +;; Local Variables:
 +;; no-byte-compile: t
 +;; End:
 +
 +;;; xml-parse-tests.el ends here.
diff --cc test/lisp/xt-mouse-tests.el
index c7e835c0311,00000000000..c0e97f57479
mode 100644,000000..100644
--- a/test/lisp/xt-mouse-tests.el
+++ b/test/lisp/xt-mouse-tests.el
@@@ -1,110 -1,0 +1,110 @@@
 +;;; xt-mouse-tests.el --- Test suite for xt-mouse.  -*- lexical-binding: t; -*-
 +
- ;; Copyright (C) 2016 Free Software Foundation, Inc.
++;; Copyright (C) 2016-2017 Free Software Foundation, Inc.
 +
 +;; Author: Philipp Stephani 
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +
 +;;; Code:
 +
 +(require 'xt-mouse)
 +
 +(defmacro with-xterm-mouse-mode (&rest body)
 +  "Run BODY with `xterm-mouse-mode' temporarily enabled."
 +  (declare (indent 0))
 +  ;; Make the frame huge so that the test input events below don't hit
 +  ;; the menu bar.
 +  `(cl-letf (((frame-width nil) 2000)
 +             ((frame-height nil) 2000)
 +             ;; Reset XTerm parameters so that the tests don't get
 +             ;; confused.
 +             ((terminal-parameter nil 'xterm-mouse-x) nil)
 +             ((terminal-parameter nil 'xterm-mouse-y) nil)
 +             ((terminal-parameter nil 'xterm-mouse-last-down) nil)
 +             ((terminal-parameter nil 'xterm-mouse-last-click) nil))
 +     (if xterm-mouse-mode
 +         (progn ,@body)
 +       (unwind-protect
 +           (progn
 +             ;; `xterm-mouse-mode' doesn't work in the initial
 +             ;; terminal.  Since we can't create a second terminal in
 +             ;; batch mode, fake it temporarily.
 +             (cl-letf (((symbol-function 'terminal-name)
 +                        (lambda (&optional _terminal) "fake-terminal")))
 +               (xterm-mouse-mode))
 +             ,@body)
 +         (xterm-mouse-mode 0)))))
 +
 +(ert-deftest xt-mouse-tracking-basic ()
 +  (should (equal (xterm-mouse-tracking-enable-sequence)
 +                 "\e[?1000h\e[?1002h\e[?1006h"))
 +  (should (equal (xterm-mouse-tracking-disable-sequence)
 +                 "\e[?1006l\e[?1002l\e[?1000l"))
 +  (with-xterm-mouse-mode
 +    (should xterm-mouse-mode)
 +    (should (terminal-parameter nil 'xterm-mouse-mode))
 +    (should-not (terminal-parameter nil 'xterm-mouse-utf-8))
 +    (let* ((unread-command-events (append "\e[M%\xD9\x81"
 +                                          "\e[M'\xD9\x81" nil))
 +           (key (read-key)))
 +      (should (consp key))
 +      (cl-destructuring-bind (event-type position . rest) key
 +        (should (equal event-type 'S-mouse-2))
 +        (should (consp position))
 +        (cl-destructuring-bind (_ _ xy . rest) position
 +          (should (equal xy '(184 . 95))))))))
 +
 +(ert-deftest xt-mouse-tracking-utf-8 ()
 +  (let ((xterm-mouse-utf-8 t))
 +    (should (equal (xterm-mouse-tracking-enable-sequence)
 +                   "\e[?1000h\e[?1002h\e[?1005h\e[?1006h"))
 +    (should (equal (xterm-mouse-tracking-disable-sequence)
 +                   "\e[?1006l\e[?1005l\e[?1002l\e[?1000l"))
 +    (with-xterm-mouse-mode
 +      (should xterm-mouse-mode)
 +      (should (terminal-parameter nil 'xterm-mouse-mode))
 +      (should (terminal-parameter nil 'xterm-mouse-utf-8))
 +      ;; The keyboard driver doesn't decode bytes in
 +      ;; `unread-command-events'.
 +      (let* ((unread-command-events (append "\e[M%\u0640\u0131"
 +                                            "\e[M'\u0640\u0131" nil))
 +             (key (read-key)))
 +        (should (consp key))
 +        (cl-destructuring-bind (event-type position . rest) key
 +          (should (equal event-type 'S-mouse-2))
 +          (should (consp position))
 +          (cl-destructuring-bind (_ _ xy . rest) position
 +            (should (equal xy '(1567 . 271)))))))))
 +
 +(ert-deftest xt-mouse-tracking-sgr ()
 +  (with-xterm-mouse-mode
 +    (should xterm-mouse-mode)
 +    (should (terminal-parameter nil 'xterm-mouse-mode))
 +    (should-not (terminal-parameter nil 'xterm-mouse-utf-8))
 +    (let* ((unread-command-events (append "\e[<5;1569;273;M"
 +                                          "\e[<5;1569;273;m" nil))
 +           (key (read-key)))
 +      (should (consp key))
 +      (cl-destructuring-bind (event-type position . rest) key
 +        (should (equal event-type 'S-mouse-2))
 +        (should (consp position))
 +        (cl-destructuring-bind (_ _ xy . rest) position
 +          (should (equal xy '(1568 . 271))))))))
 +
 +;;; xt-mouse-tests.el ends here
diff --cc test/manual/biditest.el
index c1a575017f8,00000000000..c315749e187
mode 100644,000000..100644
--- a/test/manual/biditest.el
+++ b/test/manual/biditest.el
@@@ -1,121 -1,0 +1,121 @@@
 +;;; biditest.el --- test bidi reordering in GNU Emacs display engine.
 +
- ;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
 +
 +;; Author: Eli Zaretskii
 +;; Maintainer: emacs-devel@gnu.org
 +;; Package: emacs
 +
 +;; This program is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; This program is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +
 +;; Produce a specially-formatted text file from BidiCharacterTest.txt
 +;; file that is part of the Unicode Standard's UCD package.  The file
 +;; shows the expected results of reordering according to the UBA.  The
 +;; file is supposed to be visited in Emacs, and the resulting display
 +;; compared with the expected one.
 +
 +;;; Code:
 +
 +(defun biditest-generate-testfile (input-file output-file)
 +  "Generate a bidi test file OUTPUT-FILE from data in INPUT-FILE.
 +
 +INPUT-FILE should be in the format of the BidiCharacterTest.txt file
 +available from the Unicode site, as part of the UCD database, see
 +http://www.unicode.org/Public/UCD/latest/ucd/BidiCharacterTest.txt.
 +
 +The resulting file should be viewed with `inhibit-bidi-mirroring' set to t."
 +  (let ((output-buf (get-buffer-create "*biditest-output*"))
 +	(lnum 1)
 +	tbuf)
 +    (with-temp-buffer
 +      (message "Generating output in %s ..." output-file)
 +      (setq tbuf (current-buffer))
 +      (insert-file-contents input-file)
 +      (goto-char (point-min))
 +      (while (not (eobp))
 +	(when (looking-at "^\\([0-9A-F ]+\\);\\([012]\\);\\([01]\\);\\([0-9x ]+\\);\\([0-9 ]+\\)$")
 +	  (let ((codes (match-string 1))
 +		(default-paragraph (match-string 2))
 +		(resolved-paragraph (match-string 3))
 +		;; FIXME: Should compare LEVELS with what the display
 +		;; engine actually produced.
 +		(levels (match-string 4))
 +		(indices (match-string 5)))
 +	    (setq codes (split-string codes " ")
 +		  indices (split-string indices " "))
 +	    (switch-to-buffer output-buf)
 +	    (insert (format "Test on line %d:\n\n" lnum))
 +	    ;; Force paragraph direction to what the UCD test
 +	    ;; specifies.
 +	    (insert (cond
 +		     ((string= default-paragraph "0") ;L2R
 +		      #x200e)
 +		     ((string= default-paragraph "1") ;R2L
 +		      #x200f)
 +		     (t "")))	; dynamic
 +	    ;; Insert the characters
 +	    (mapc (lambda (code)
 +		    (insert (string-to-number code 16)))
 +		  codes)
 +	    (insert "\n\n")
 +	    ;; Insert the expected results
 +	    (insert "Expected result:\n\n")
 +	    ;; We want the expected results displayed exactly as
 +	    ;; specified in the test file, without any reordering, so
 +	    ;; we override the directional properties of all of the
 +	    ;; characters in the expected result by prepending
 +	    ;; LRO/RLO.
 +	    (cond ((string= resolved-paragraph "0")
 +		   (insert #x200e #x202d))
 +		  ((string= resolved-paragraph "1")
 +		   (insert #x200f #x202e)
 +		   ;; We need to reverse the list of indices for R2L
 +		   ;; paragraphs, so that their logical order on
 +		   ;; display matches user expectations.
 +		   (setq indices (nreverse indices))))
 +	    (mapc (lambda (index)
 +		    (insert (string-to-number
 +			     (nth (string-to-number index 10) codes)
 +			     16)))
 +		  indices)
 +	    (insert #x202c)	; end the embedding
 +	    (insert "\n\n"))
 +	  (switch-to-buffer tbuf))
 +	(forward-line 1)
 +	(setq lnum (1+ lnum)))
 +      (switch-to-buffer output-buf)
 +      (let ((coding-system-for-write 'utf-8-unix))
 +	(write-file output-file))
 +      (message "Generating output in %s ... done" output-file))))
 +
 +(defun biditest-create-test ()
 +  "Create a test file for testing the Emacs bidirectional display.
 +
 +The resulting file should be viewed with `inhibit-bidi-mirroring' set to t."
 +  (biditest-generate-testfile (pop command-line-args-left)
 +			      (or (pop command-line-args-left)
 +				  "biditest.txt")))
 +
 +;; A handy function for displaying the resolved bidi levels.
 +(defun bidi-levels ()
 +  "Display the resolved bidirectional levels of characters on current line.
 +
 +The results can be compared with the levels stated in the
 +BidiCharacterTest.txt file."
 +  (interactive)
 +  (message "%s" (bidi-resolved-levels)))
 +
 +(define-key global-map [f8] 'bidi-levels)
diff --cc test/manual/cedet/cedet-utests.el
index ae9d576f0f5,00000000000..b8396b822b9
mode 100644,000000..100644
--- a/test/manual/cedet/cedet-utests.el
+++ b/test/manual/cedet/cedet-utests.el
@@@ -1,515 -1,0 +1,515 @@@
 +;;; cedet-utests.el --- Run all unit tests in the CEDET suite.
 +
- ;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2008-2017 Free Software Foundation, Inc.
 +
 +;; Author: Eric M. Ludlam 
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +;;
 +;; Remembering to run all the unit tests available in CEDET one at a
 +;; time is a bit time consuming.  This links all the tests together
 +;; into one command.
 +
 +(require 'cedet)
 +;;; Code:
 +(defvar cedet-utest-test-alist
 +  '(
 +    ;;
 +    ;; COMMON
 +    ;;
 +
 +    ;; Test inversion
 +    ("inversion" . inversion-unit-test)
 +
 +    ;; EZ Image dumping.
 +    ("ezimage associations" . ezimage-image-association-dump)
 +    ("ezimage images" . ezimage-image-dump)
 +
 +    ;; Pulse
 +    ("pulse interactive test" . (lambda () (pulse-test t)))
 +
 +    ;; Files
 +    ("cedet file conversion" . cedet-files-utest)
 +
 +    ;;
 +    ;; EIEIO
 +    ;;
 +    ("eieio" . (lambda () (let ((lib (locate-library "eieio-tests.el"
 +						     t)))
 +			    (load-file lib))))
 +    ("eieio: browser" . eieio-browse)
 +    ("eieio: custom" . (lambda ()
 +			 (require 'eieio-custom)
 +			 (customize-variable 'eieio-widget-test)))
 +    ("eieio: chart" . (lambda ()
 +			(if (cedet-utest-noninteractive)
 +			    (message " ** Skipping test in noninteractive mode.")
 +			  (chart-test-it-all))))
 +    ;;
 +    ;; EDE
 +    ;;
 +
 +    ;; @todo - Currently handled in the integration tests.  Need
 +    ;;         some simpler unit tests here.
 +
 +    ;;
 +    ;; SEMANTIC
 +    ;;
 +    ("semantic: lex spp table write" . semantic-lex-spp-write-utest)
 +    ("semantic: multi-lang parsing" . semantic-utest-main)
 +    ("semantic: C preprocessor" . semantic-utest-c)
 +    ("semantic: analyzer tests" . semantic-ia-utest)
 +    ("semanticdb: data cache" . semantic-test-data-cache)
 +    ("semantic: throw-on-input" .
 +     (lambda ()
 +       (if (cedet-utest-noninteractive)
 +	   (message " ** Skipping test in noninteractive mode.")
 +	 (semantic-test-throw-on-input))))
 +
 +    ("semantic: gcc: output parse test" . semantic-gcc-test-output-parser)
 +    ;;
 +    ;; SRECODE
 +    ;;
 +    ("srecode: fields" . srecode-field-utest)
 +    ("srecode: templates" . srecode-utest-template-output)
 +    ("srecode: show maps" . srecode-get-maps)
 +    ("srecode: getset" . srecode-utest-getset-output)
 +   )
 +  "Alist of all the tests in CEDET we should run.")
 +
 +(defvar cedet-running-master-tests nil
 +  "Non-nil when CEDET-utest is running all the tests.")
 +
 +(defun cedet-utest (&optional exit-on-error)
 +  "Run the CEDET unit tests.
 +EXIT-ON-ERROR causes the test suite to exit on an error, instead
 +of just logging the error."
 +  (interactive)
 +  (if (or (not (featurep 'semanticdb-mode))
 +	  (not (semanticdb-minor-mode-p)))
 +      (error "CEDET Tests require: M-x semantic-load-enable-minimum-features"))
 +  (cedet-utest-log-setup "ALL TESTS")
 +  (let ((tl cedet-utest-test-alist)
 +	(notes nil)
 +	(err nil)
 +	(start (current-time))
 +	(end nil)
 +	(cedet-running-master-tests t)
 +	)
 +    (dolist (T tl)
 +      (cedet-utest-add-log-item-start (car T))
 +      (setq notes nil err nil)
 +      (condition-case Cerr
 +	  (progn
 +	    (funcall (cdr T))
 +	    )
 +	(error
 +	 (setq err (format "ERROR: %S" Cerr))
 +	 ;;(message "Error caught: %s" Cerr)
 +	 ))
 +
 +      ;; Cleanup stray input and events that are in the way.
 +      ;; Not doing this causes sit-for to not refresh the screen.
 +      ;; Doing this causes the user to need to press keys more frequently.
 +      (when (and (interactive-p) (input-pending-p))
 +	(if (fboundp 'read-event)
 +	    (read-event)
 +	  (read-char)))
 +
 +      (cedet-utest-add-log-item-done notes err)
 +      (when (and exit-on-error err)
 +	(message "to debug this test point, execute:")
 +	(message "%S" (cdr T))
 +	(message "\n ** Exiting Test Suite. ** \n")
 +	(throw 'cedet-utest-exit-on-error t)
 +	)
 +      )
 +    (setq end (current-time))
 +    (cedet-utest-log-shutdown-msg "ALL TESTS" start end)
 +    nil))
 +
 +(defun cedet-utest-noninteractive ()
 +  "Return non-nil if running non-interactively."
 +  (if (featurep 'xemacs)
 +      (noninteractive)
 +    noninteractive))
 +
 +;;;###autoload
 +(defun cedet-utest-batch ()
 +  "Run the CEDET unit test in BATCH mode."
 +  (unless (cedet-utest-noninteractive)
 +    (error "`cedet-utest-batch' is to be used only with -batch"))
 +  (condition-case err
 +      (when (catch 'cedet-utest-exit-on-error
 +	      ;; Get basic semantic features up.
 +	      (semantic-load-enable-minimum-features)
 +	      ;; Disables all caches related to semantic DB so all
 +	      ;; tests run as if we have bootstrapped CEDET for the
 +	      ;; first time.
 +	      (setq-default semanticdb-new-database-class 'semanticdb-project-database)
 +	      (message "Disabling existing Semantic Database Caches.")
 +
 +	      ;; Disabling the srecoder map, we won't load a pre-existing one
 +	      ;; and will be forced to bootstrap a new one.
 +	      (setq srecode-map-save-file nil)
 +
 +	      ;; Run the tests
 +	      (cedet-utest t)
 +	      )
 +	(kill-emacs 1))
 +    (error
 +     (error "Error in unit test harness:\n  %S" err))
 +    )
 +  )
 +
 +;;; Logging utility.
 +;;
 +(defvar cedet-utest-frame nil
 +  "Frame used during cedet unit test logging.")
 +(defvar cedet-utest-buffer nil
 +  "Frame used during cedet unit test logging.")
 +(defvar cedet-utest-frame-parameters
 +  '((name . "CEDET-UTEST")
 +    (width . 80)
 +    (height . 25)
 +    (minibuffer . t))
 +  "Frame parameters used for the cedet utest log frame.")
 +
 +(defvar cedet-utest-last-log-item nil
 +  "Remember the last item we were logging for.")
 +
 +(defvar cedet-utest-log-timer nil
 +  "During a test, track the start time.")
 +
 +(defun cedet-utest-log-setup (&optional title)
 +  "Setup a frame and buffer for unit testing.
 +Optional argument TITLE is the title of this testing session."
 +  (setq cedet-utest-log-timer (current-time))
 +  (if (cedet-utest-noninteractive)
 +      (message "\n>> Setting up %s tests to run @ %s\n"
 +	       (or title "")
 +	       (current-time-string))
 +
 +    ;; Interactive mode needs a frame and buffer.
 +    (when (or (not cedet-utest-frame) (not (frame-live-p cedet-utest-frame)))
 +      (setq cedet-utest-frame (make-frame cedet-utest-frame-parameters)))
 +    (when (or (not cedet-utest-buffer) (not (buffer-live-p cedet-utest-buffer)))
 +      (setq cedet-utest-buffer (get-buffer-create "*CEDET utest log*")))
 +    (save-excursion
 +      (set-buffer cedet-utest-buffer)
 +      (setq cedet-utest-last-log-item nil)
 +      (when (not cedet-running-master-tests)
 +	(erase-buffer))
 +      (insert "\n\nSetting up "
 +	      (or title "")
 +	      " tests to run @ " (current-time-string) "\n\n"))
 +    (let ((oframe (selected-frame)))
 +      (unwind-protect
 +	  (progn
 +	    (select-frame cedet-utest-frame)
 +	    (switch-to-buffer cedet-utest-buffer t))
 +	(select-frame oframe)))
 +    ))
 +
 +(defun cedet-utest-elapsed-time (start end)
 +  "Copied from elp.el.  Was elp-elapsed-time.
 +Argument START and END bound the time being calculated."
 +  (+ (* (- (car end) (car start)) 65536.0)
 +     (- (car (cdr end)) (car (cdr start)))
 +     (/ (- (car (cdr (cdr end))) (car (cdr (cdr start)))) 1000000.0)))
 +
 +(defun cedet-utest-log-shutdown (title &optional errorcondition)
 +  "Shut-down a larger test suite.
 +TITLE is the section that is done.
 +ERRORCONDITION is some error that may have occurred during testing."
 +  (let ((endtime (current-time))
 +	)
 +    (cedet-utest-log-shutdown-msg title cedet-utest-log-timer endtime)
 +    (setq cedet-utest-log-timer nil)
 +    ))
 +
 +(defun cedet-utest-log-shutdown-msg (title startime endtime)
 +  "Show a shutdown message with TITLE, STARTIME, and ENDTIME."
 +  (if (cedet-utest-noninteractive)
 +      (progn
 +	(message "\n>> Test Suite %s ended at @ %s"
 +		 title
 +		 (format-time-string "%c" endtime))
 +	(message "     Elapsed Time %.2f Seconds\n"
 +		 (cedet-utest-elapsed-time startime endtime)))
 +
 +    (save-excursion
 +      (set-buffer cedet-utest-buffer)
 +      (goto-char (point-max))
 +      (insert "\n>> Test Suite " title " ended at @ "
 +	      (format-time-string "%c" endtime) "\n"
 +	      "     Elapsed Time "
 +	      (number-to-string
 +	       (cedet-utest-elapsed-time startime endtime))
 +	      " Seconds\n * "))
 +    ))
 +
 +(defun cedet-utest-show-log-end ()
 +  "Show the end of the current unit test log."
 +  (unless (cedet-utest-noninteractive)
 +    (let* ((cb (current-buffer))
 +	   (cf (selected-frame))
 +	   (bw (or (get-buffer-window cedet-utest-buffer t)
 +		   (get-buffer-window (switch-to-buffer cedet-utest-buffer) t)))
 +	   (lf (window-frame bw))
 +	   )
 +      (select-frame lf)
 +      (select-window bw)
 +      (goto-char (point-max))
 +      (select-frame cf)
 +      (set-buffer cb)
 +      )))
 +
 +(defun cedet-utest-post-command-hook ()
 +  "Hook run after the current log command was run."
 +    (if (cedet-utest-noninteractive)
 +	(message "")
 +      (save-excursion
 +	(set-buffer cedet-utest-buffer)
 +	(goto-char (point-max))
 +	(insert "\n\n")))
 +    (setq cedet-utest-last-log-item nil)
 +    (remove-hook 'post-command-hook 'cedet-utest-post-command-hook)
 +    )
 +
 +(defun cedet-utest-add-log-item-start (item)
 +  "Add ITEM into the log as being started."
 +  (unless (equal item cedet-utest-last-log-item)
 +    (setq cedet-utest-last-log-item item)
 +    ;; This next line makes sure we clear out status during logging.
 +    (add-hook 'post-command-hook 'cedet-utest-post-command-hook)
 +
 +    (if (cedet-utest-noninteractive)
 +	(message " - Running %s ..." item)
 +      (save-excursion
 +	(set-buffer cedet-utest-buffer)
 +	(goto-char (point-max))
 +	(when (not (bolp)) (insert "\n"))
 +	(insert "Running " item " ... ")
 +	(sit-for 0)
 +	))
 +    (cedet-utest-show-log-end)
 +    ))
 +
 +(defun cedet-utest-add-log-item-done (&optional notes err precr)
 +  "Add into the log that the last item is done.
 +Apply NOTES to the doneness of the log.
 +Apply ERR if there was an error in previous item.
 +Optional argument PRECR indicates to prefix the done msg w/ a newline."
 +  (if (cedet-utest-noninteractive)
 +      ;; Non-interactive-mode - show a message.
 +      (if notes
 +	  (message "   * %s {%s}" (or err "done") notes)
 +	(message "   * %s" (or err "done")))
 +    ;; Interactive-mode - insert into the buffer.
 +    (save-excursion
 +      (set-buffer cedet-utest-buffer)
 +      (goto-char (point-max))
 +      (when precr (insert "\n"))
 +      (if err
 +	  (insert err)
 +	(insert "done")
 +	(when notes (insert " (" notes ")")))
 +      (insert "\n")
 +      (setq cedet-utest-last-log-item nil)
 +      (sit-for 0)
 +      )))
 +
 +;;; INDIVIDUAL TEST API
 +;;
 +;; Use these APIs to start and log information.
 +;;
 +;; The other fcns will be used to log across all the tests at once.
 +(defun cedet-utest-log-start (testname)
 +  "Setup the log for the test TESTNAME."
 +  ;; Make sure we have a log buffer.
 +  (save-window-excursion
 +    (when (or (not cedet-utest-buffer)
 +	      (not (buffer-live-p cedet-utest-buffer))
 +	      (not (get-buffer-window cedet-utest-buffer t))
 +	      )
 +      (cedet-utest-log-setup))
 +    ;; Add our startup message.
 +    (cedet-utest-add-log-item-start testname)
 +    ))
 +
 +(defun cedet-utest-log(format &rest args)
 +  "Log the text string FORMAT.
 +The rest of the ARGS are used to fill in FORMAT with `format'."
 +  (if (cedet-utest-noninteractive)
 +      (apply 'message format args)
 +    (save-excursion
 +      (set-buffer cedet-utest-buffer)
 +      (goto-char (point-max))
 +      (when (not (bolp)) (insert "\n"))
 +      (insert (apply 'format format args))
 +      (insert "\n")
 +      (sit-for 0)
 +      ))
 +  (cedet-utest-show-log-end)
 +  )
 +
 +;;; Inversion tests
 +
 +(defun inversion-unit-test ()
 +  "Test inversion to make sure it can identify different version strings."
 +  (interactive)
 +  (let ((c1 (inversion-package-version 'inversion))
 +	(c1i (inversion-package-incompatibility-version 'inversion))
 +	(c2 (inversion-decode-version  "1.3alpha2"))
 +	(c3 (inversion-decode-version  "1.3beta4"))
 +	(c4 (inversion-decode-version  "1.3 beta5"))
 +	(c5 (inversion-decode-version  "1.3.4"))
 +	(c6 (inversion-decode-version  "2.3alpha"))
 +	(c7 (inversion-decode-version  "1.3"))
 +	(c8 (inversion-decode-version  "1.3pre1"))
 +	(c9 (inversion-decode-version  "2.4 (patch 2)"))
 +	(c10 (inversion-decode-version "2.4 (patch 3)"))
 +	(c11 (inversion-decode-version "2.4.2.1"))
 +	(c12 (inversion-decode-version "2.4.2.2"))
 +	)
 +    (if (not (and
 +	      (inversion-= c1 c1)
 +	      (inversion-< c1i c1)
 +	      (inversion-< c2 c3)
 +	      (inversion-< c3 c4)
 +	      (inversion-< c4 c5)
 +	      (inversion-< c5 c6)
 +	      (inversion-< c2 c4)
 +	      (inversion-< c2 c5)
 +	      (inversion-< c2 c6)
 +	      (inversion-< c3 c5)
 +	      (inversion-< c3 c6)
 +	      (inversion-< c7 c6)
 +	      (inversion-< c4 c7)
 +	      (inversion-< c2 c7)
 +	      (inversion-< c8 c6)
 +	      (inversion-< c8 c7)
 +	      (inversion-< c4 c8)
 +	      (inversion-< c2 c8)
 +	      (inversion-< c9 c10)
 +	      (inversion-< c10 c11)
 +	      (inversion-< c11 c12)
 +	      ;; Negatives
 +	      (not (inversion-< c3 c2))
 +	      (not (inversion-< c4 c3))
 +	      (not (inversion-< c5 c4))
 +	      (not (inversion-< c6 c5))
 +	      (not (inversion-< c7 c2))
 +	      (not (inversion-< c7 c8))
 +	      (not (inversion-< c12 c11))
 +	      ;; Test the tester on inversion
 +	      (not (inversion-test 'inversion inversion-version))
 +	      ;; Test that we throw an error
 +	      (inversion-test 'inversion "0.0.0")
 +	      (inversion-test 'inversion "1000.0")
 +	      ))
 +	(error "Inversion tests failed")
 +      (message "Inversion tests passed."))))
 +
 +;;; cedet-files unit test
 +
 +(defvar cedet-files-utest-list
 +  '(
 +    ( "/home/me/src/myproj/src/foo.c" . "!home!me!src!myproj!src!foo.c" )
 +    ( "c:/work/myproj/foo.el" . "!drive_c!work!myproj!foo.el" )
 +    ( "//windows/proj/foo.java" . "!!windows!proj!foo.java" )
 +    ( "/home/me/proj!bang/foo.c" . "!home!me!proj!!bang!foo.c" )
 +    )
 +  "List of different file names to test.
 +Each entry is a cons cell of ( FNAME . CONVERTED )
 +where FNAME is some file name, and CONVERTED is what it should be
 +converted into.")
 +
 +(defun cedet-files-utest ()
 +  "Test out some file name conversions."
 +  (interactive)
 +  (let ((idx 0))
 +    (dolist (FT cedet-files-utest-list)
 +
 +      (setq idx (+ idx 1))
 +
 +      (let ((dir->file (cedet-directory-name-to-file-name (car FT) t))
 +	    (file->dir (cedet-file-name-to-directory-name (cdr FT) t))
 +	    )
 +
 +	(unless (string= (cdr FT) dir->file)
 +	  (error "Failed: %d.  Found: %S Wanted: %S"
 +		 idx dir->file (cdr FT))
 +	  )
 +
 +	(unless (string= file->dir (car FT))
 +	  (error "Failed: %d.  Found: %S Wanted: %S"
 +		 idx file->dir (car FT)))))))
 +
 +;;; pulse test
 +
 +(defun pulse-test (&optional no-error)
 +  "Test the lightening function for pulsing a line.
 +When optional NO-ERROR don't throw an error if we can't run tests."
 +  (interactive)
 +  (if (or (not pulse-flag) (not (pulse-available-p)))
 +      (if no-error
 +	  nil
 +	(error (concat "Pulse test only works on versions of Emacs"
 +		       " that support pulsing")))
 +    ;; Run the tests
 +    (when (interactive-p)
 +      (message " Pulse one line.")
 +      (read-char))
 +    (pulse-momentary-highlight-one-line (point))
 +    (when (interactive-p)
 +      (message " Pulse a region.")
 +      (read-char))
 +    (pulse-momentary-highlight-region (point)
 +				      (save-excursion
 +					(condition-case nil
 +					    (forward-char 30)
 +					  (error nil))
 +					(point)))
 +    (when (interactive-p)
 +      (message " Pulse line a specific color.")
 +      (read-char))
 +    (pulse-momentary-highlight-one-line (point) 'modeline)
 +    (when (interactive-p)
 +      (message " Pulse a pre-existing overlay.")
 +      (read-char))
 +    (let* ((start (point-at-bol))
 +	   (end (save-excursion
 +		  (end-of-line)
 +		  (when (not (eobp))
 +		    (forward-char 1))
 +		  (point)))
 +	   (o (make-overlay start end))
 +	   )
 +      (pulse-momentary-highlight-overlay o)
 +      (if (overlay-buffer o)
 +	  (delete-overlay o)
 +	(error "Non-temporary overlay was deleted!"))
 +      )
 +    (when (interactive-p)
 +      (message "Done!"))))
 +
 +(provide 'cedet-utests)
 +
 +;;; cedet-utests.el ends here
diff --cc test/manual/cedet/ede-tests.el
index 32971e441ef,00000000000..fdad01c1ff1
mode 100644,000000..100644
--- a/test/manual/cedet/ede-tests.el
+++ b/test/manual/cedet/ede-tests.el
@@@ -1,87 -1,0 +1,87 @@@
 +;;; ede-tests.el --- Some tests for the Emacs Development Environment
 +
- ;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2008-2017 Free Software Foundation, Inc.
 +
 +;; Author: Eric M. Ludlam 
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +
 +;; Extracted from ede-locate.el in the CEDET distribution.
 +
 +;;; Code:
 +
 +;;; From ede-locate:
 +
 +(require 'ede/locate)
 +
 +;;; TESTS
 +;;
 +;; Some testing routines.
 +(defun ede-locate-test-locate (file)
 +  "Test EDE Locate on FILE using LOCATE type.
 +The search is done with the current EDE root."
 +  (interactive "sFile: ")
 +  (let ((loc (ede-locate-locate
 +	      "test"
 +	      :root (ede-project-root-directory
 +		     (ede-toplevel)))))
 +    (data-debug-new-buffer "*EDE Locate ADEBUG*")
 +    (ede-locate-file-in-project loc file)
 +    (data-debug-insert-object-slots loc "]"))
 +  )
 +
 +(defun ede-locate-test-global (file)
 +  "Test EDE Locate on FILE using GNU Global type.
 +The search is done with the current EDE root."
 +  (interactive "sFile: ")
 +  (let ((loc (ede-locate-global
 +	      "test"
 +	      :root (ede-project-root-directory
 +		     (ede-toplevel)))))
 +    (data-debug-new-buffer "*EDE Locate ADEBUG*")
 +    (ede-locate-file-in-project loc file)
 +    (data-debug-insert-object-slots loc "]"))
 +  )
 +
 +(defun ede-locate-test-idutils (file)
 +  "Test EDE Locate on FILE using ID Utils type.
 +The search is done with the current EDE root."
 +  (interactive "sFile: ")
 +  (let ((loc (ede-locate-idutils
 +	      "test"
 +	      :root (ede-project-root-directory
 +		     (ede-toplevel)))))
 +    (data-debug-new-buffer "*EDE Locate ADEBUG*")
 +    (ede-locate-file-in-project loc file)
 +    (data-debug-insert-object-slots loc "]"))
 +  )
 +
 +(defun ede-locate-test-cscope (file)
 +  "Test EDE Locate on FILE using CScope type.
 +The search is done with the current EDE root."
 +  (interactive "sFile: ")
 +  (let ((loc (ede-locate-cscope
 +	      "test"
 +	      :root (ede-project-root-directory
 +		     (ede-toplevel)))))
 +    (data-debug-new-buffer "*EDE Locate ADEBUG*")
 +    (ede-locate-file-in-project loc file)
 +    (data-debug-insert-object-slots loc "]"))
 +  )
 +
 +;;; ede-test.el ends here
diff --cc test/manual/cedet/semantic-ia-utest.el
index a5b70b8326f,00000000000..cf89daf1490
mode 100644,000000..100644
--- a/test/manual/cedet/semantic-ia-utest.el
+++ b/test/manual/cedet/semantic-ia-utest.el
@@@ -1,528 -1,0 +1,528 @@@
 +;;; semantic-ia-utest.el --- Analyzer unit tests
 +
- ;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2008-2017 Free Software Foundation, Inc.
 +
 +;; Author: Eric M. Ludlam 
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +;;
 +;; Use marked-up files in the test directory and run the analyzer
 +;; on them.  Make sure the answers are correct.
 +;;
 +;; Each file has cursor keys in them of the form:
 +;;   // -#- ("ans1" "ans2" )
 +;; where # is 1, 2, 3, etc, and some sort of answer list.
 +
 +;;; Code:
 +(require 'semantic)
 +(require 'semantic/analyze)
 +(require 'semantic/analyze/refs)
 +(require 'semantic/symref)
 +(require 'semantic/symref/filter)
 +
 +(load-file "cedet-utests.el")
 +
 +(defvar semantic-ia-utest-file-list
 +  '(
 +    "tests/testdoublens.cpp"
 +    "tests/testsubclass.cpp"
 +    "tests/testtypedefs.cpp"
 +    "tests/testfriends.cpp"
 +    "tests/testnsp.cpp"
 +    "tests/testsppcomplete.c"
 +    "tests/testvarnames.c"
 +    "tests/testjavacomp.java"
 +    )
 +  "List of files with analyzer completion test points.")
 +
 +(defvar semantic-ia-utest-error-log-list nil
 +  "List of errors occurring during a run.")
 +
 +;;;###autoload
 +(defun semantic-ia-utest (&optional arg)
 +  "Run the semantic ia unit test against stored sources.
 +Argument ARG specifies which set of tests to run.
 + 1 - ia utests
 + 2 - regs utests
 + 3 - symrefs utests
 + 4 - symref count utests"
 +  (interactive "P")
 +  (save-excursion
 +
 +    (let ((fl semantic-ia-utest-file-list)
 +	  (semantic-ia-utest-error-log-list nil)
 +	  )
 +
 +      (cedet-utest-log-setup "ANALYZER")
 +
 +      (set-buffer (semantic-find-file-noselect
 +		   (or (locate-library "semantic-ia-utest.el")
 +		       "semantic-ia-utest.el")))
 +
 +      (while fl
 +
 +	;; Make sure we have the files we think we have.
 +	(when (not (file-exists-p (car fl)))
 +	  (error "Cannot find unit test file: %s" (car fl)))
 +
 +	;; Run the tests.
 +	(let ((fb (find-buffer-visiting (car fl)))
 +	      (b (semantic-find-file-noselect (car fl) t)))
 +
 +	  ;; Run the test on it.
 +	  (save-excursion
 +	    (set-buffer b)
 +
 +	    ;; This line will also force the include, scope, and typecache.
 +	    (semantic-clear-toplevel-cache)
 +	    ;; Force tags to be parsed.
 +	    (semantic-fetch-tags)
 +
 +	    (semantic-ia-utest-log "  ** Starting tests in %s"
 +				   (buffer-name))
 +
 +	    (when (or (not arg) (= arg 1))
 +	      (semantic-ia-utest-buffer))
 +
 +	    (when (or (not arg) (= arg 2))
 +	      (set-buffer b)
 +	      (semantic-ia-utest-buffer-refs))
 +
 +	    (when (or (not arg) (= arg 3))
 +	      (set-buffer b)
 +	      (semantic-sr-utest-buffer-refs))
 +
 +	    (when (or (not arg) (= arg 4))
 +	      (set-buffer b)
 +	      (semantic-src-utest-buffer-refs))
 +
 +	    (semantic-ia-utest-log "  ** Completed tests in %s\n"
 +				   (buffer-name))
 +	    )
 +
 +	  ;; If it wasn't already in memory, whack it.
 +	  (when (not fb)
 +	    (kill-buffer b))
 +	  )
 +	(setq fl (cdr fl)))
 +
 +      (cedet-utest-log-shutdown
 +       "ANALYZER"
 +       (when semantic-ia-utest-error-log-list
 +	 (format "%s Failures found."
 +		 (length semantic-ia-utest-error-log-list))))
 +      (when semantic-ia-utest-error-log-list
 +	(error "Failures found during analyzer unit tests"))
 +      ))
 +  )
 +
 +(defun semantic-ia-utest-buffer ()
 +  "Run analyzer completion unit-test pass in the current buffer."
 +
 +  (let* ((idx 1)
 +	 (regex-p nil)
 +	 (regex-a nil)
 +	 (p nil)
 +	 (a nil)
 +	 (pass nil)
 +	 (fail nil)
 +	 (actual nil)
 +	 (desired nil)
 +	 ;; Exclude unpredictable system files in the
 +	 ;; header include list.
 +	 (semanticdb-find-default-throttle
 +	  (remq 'system semanticdb-find-default-throttle))
 +	 )
 +    ;; Keep looking for test points until we run out.
 +    (while (save-excursion
 +	     (setq regex-p (concat "//\\s-*-" (number-to-string idx) "-" )
 +		   regex-a (concat "//\\s-*#" (number-to-string idx) "#" ))
 +	     (goto-char (point-min))
 +	     (save-match-data
 +	       (when (re-search-forward regex-p nil t)
 +		 (setq p (match-beginning 0))))
 +	     (save-match-data
 +	       (when (re-search-forward regex-a nil t)
 +		 (setq a (match-end 0))))
 +	     (and p a))
 +
 +      (save-excursion
 +
 +	(goto-char p)
 +
 +	(let* ((ctxt (semantic-analyze-current-context))
 +	       (acomp
 +		(condition-case nil
 +		    (semantic-analyze-possible-completions ctxt)
 +		  (error nil))))
 +	  (setq actual (mapcar 'semantic-tag-name acomp)))
 +
 +	(goto-char a)
 +
 +	(let ((bss (buffer-substring-no-properties (point) (point-at-eol))))
 +	  (condition-case nil
 +	      (setq desired (read bss))
 +	    (error (setq desired (format "  FAILED TO PARSE: %S"
 +					 bss)))))
 +
 +	(if (equal actual desired)
 +	    (setq pass (cons idx pass))
 +	  (setq fail (cons idx fail))
 +	  (semantic-ia-utest-log
 +	   "    Failed %d.  Desired: %S Actual %S"
 +	   idx desired actual)
 +	  (add-to-list 'semantic-ia-utest-error-log-list
 +		       (list (buffer-name) idx desired actual)
 +		       )
 +
 +	  )
 +	)
 +
 +      (setq p nil a nil)
 +      (setq idx (1+ idx)))
 +
 +    (if fail
 +	(progn
 +	  (semantic-ia-utest-log
 +	   "    Unit tests (completions) failed tests %S"
 +	   (reverse fail))
 +	  )
 +      (semantic-ia-utest-log "    Unit tests (completions) passed (%d total)"
 +			     (- idx 1)))
 +
 +    ))
 +
 +(defun semantic-ia-utest-buffer-refs ()
 +  "Run an analyze-refs unit-test pass in the current buffer."
 +
 +  (let* ((idx 1)
 +	 (regex-p nil)
 +	 (p nil)
 +	 (pass nil)
 +	 (fail nil)
 +	 ;; Exclude unpredictable system files in the
 +	 ;; header include list.
 +	 (semanticdb-find-default-throttle
 +	  (remq 'system semanticdb-find-default-throttle))
 +	 )
 +    ;; Keep looking for test points until we run out.
 +    (while (save-excursion
 +	     (setq regex-p (concat "//\\s-*\\^" (number-to-string idx) "^" )
 +		   )
 +	     (goto-char (point-min))
 +	     (save-match-data
 +	       (when (re-search-forward regex-p nil t)
 +		 (setq p (match-beginning 0))))
 +	     p)
 +
 +      (save-excursion
 +
 +	(goto-char p)
 +	(forward-char -1)
 +
 +	(let* ((ct (semantic-current-tag))
 +	       (refs (semantic-analyze-tag-references ct))
 +	       (impl (semantic-analyze-refs-impl refs t))
 +	       (proto (semantic-analyze-refs-proto refs t))
 +	       (pf nil)
 +	       )
 +	  (setq
 +	   pf
 +	   (catch 'failed
 +	     (if (and impl proto (car impl) (car proto))
 +		 (let (ct2 ref2 impl2 proto2
 +			   newstart)
 +		   (cond
 +		    ((semantic-equivalent-tag-p (car impl) ct)
 +		     ;; We are on an IMPL.  Go To the proto, and find matches.
 +		     (semantic-go-to-tag (car proto))
 +		     (setq newstart (car proto))
 +		     )
 +		    ((semantic-equivalent-tag-p (car proto) ct)
 +		     ;; We are on a PROTO.  Go to the imple, and find matches
 +		     (semantic-go-to-tag (car impl))
 +		     (setq newstart (car impl))
 +		     )
 +		    (t
 +		     ;; No matches is a fail.
 +		     (throw 'failed t)
 +		     ))
 +		   ;; Get the new tag, does it match?
 +		   (setq ct2 (semantic-current-tag))
 +
 +		   ;; Does it match?
 +		   (when (not (semantic-equivalent-tag-p ct2 newstart))
 +		     (throw 'failed t))
 +
 +		   ;; Can we double-jump?
 +		   (setq ref2 (semantic-analyze-tag-references ct)
 +			 impl2 (semantic-analyze-refs-impl ref2 t)
 +			 proto2 (semantic-analyze-refs-proto ref2 t))
 +
 +		   (when (or (not (and impl2 proto2))
 +			     (not
 +			      (and (semantic-equivalent-tag-p
 +				    (car impl) (car impl2))
 +				   (semantic-equivalent-tag-p
 +				    (car proto) (car proto2)))))
 +		     (throw 'failed t))
 +		   )
 +
 +	       ;; Else, no matches at all, so another fail.
 +	       (throw 'failed t)
 +	       )))
 +
 +	   (if (not pf)
 +	      ;; We passed
 +	      (setq pass (cons idx pass))
 +	    ;; We failed.
 +	    (setq fail (cons idx fail))
 +	    (semantic-ia-utest-log
 +	     "    Failed %d.  For %s (Num impls %d) (Num protos %d)"
 +	     idx (if ct (semantic-tag-name ct) "")
 +	     (length impl) (length proto))
 +	    (add-to-list 'semantic-ia-utest-error-log-list
 +			 (list (buffer-name) idx)
 +			 )
 +	    ))
 +
 +	(setq p nil)
 +	(setq idx (1+ idx))
 +
 +	))
 +
 +    (if fail
 +	(progn
 +	  (semantic-ia-utest-log
 +	   "    Unit tests (refs) failed tests")
 +	  )
 +      (semantic-ia-utest-log "    Unit tests (refs) passed (%d total)"
 +			     (- idx 1)))
 +
 +    ))
 +
 +(defun semantic-sr-utest-buffer-refs ()
 +  "Run a symref unit-test pass in the current buffer."
 +
 +  ;; This line will also force the include, scope, and typecache.
 +  (semantic-clear-toplevel-cache)
 +  ;; Force tags to be parsed.
 +  (semantic-fetch-tags)
 +
 +  (let* ((idx 1)
 +	 (tag nil)
 +	 (regex-p nil)
 +	 (desired nil)
 +	 (actual-result nil)
 +	 (actual nil)
 +	 (pass nil)
 +	 (fail nil)
 +	 (symref-tool-used nil)
 +	 ;; Exclude unpredictable system files in the
 +	 ;; header include list.
 +	 (semanticdb-find-default-throttle
 +	  (remq 'system semanticdb-find-default-throttle))
 +	 )
 +    ;; Keep looking for test points until we run out.
 +    (while (save-excursion
 +	     (setq regex-p (concat "//\\s-*\\%" (number-to-string idx) "%" )
 +		   )
 +	     (goto-char (point-min))
 +	     (save-match-data
 +	       (when (re-search-forward regex-p nil t)
 +		 (setq tag (semantic-current-tag))
 +		 (goto-char (match-end 0))
 +		 (setq desired (read (buffer-substring (point) (point-at-eol))))
 +		 ))
 +	     tag)
 +
 +      (setq actual-result (semantic-symref-find-references-by-name
 +			   (semantic-tag-name tag) 'target
 +			   'symref-tool-used))
 +
 +      (if (not actual-result)
 +	  (progn
 +	    (setq fail (cons idx fail))
 +	    (semantic-ia-utest-log
 +	     "  Failed FNames %d: No results." idx)
 +	    (semantic-ia-utest-log
 +	     "  Failed Tool: %s" (object-name symref-tool-used))
 +
 +	    (add-to-list 'semantic-ia-utest-error-log-list
 +			 (list (buffer-name) idx)
 +			 )
 +	    )
 +
 +	(setq actual (list (sort (mapcar
 +				  'file-name-nondirectory
 +				  (semantic-symref-result-get-files actual-result))
 +				 'string<)
 +			   (sort
 +			    (mapcar
 +			     'semantic-format-tag-canonical-name
 +			     (semantic-symref-result-get-tags actual-result))
 +			    'string<)))
 +
 +
 +	(if (equal desired actual)
 +	    ;; We passed
 +	    (setq pass (cons idx pass))
 +	  ;; We failed.
 +	  (setq fail (cons idx fail))
 +	  (when (not (equal (car actual) (car desired)))
 +	    (semantic-ia-utest-log
 +	     "  Failed FNames %d: Actual: %S Desired: %S"
 +	     idx (car actual) (car desired))
 +	    (semantic-ia-utest-log
 +	     "  Failed Tool: %s" (object-name symref-tool-used))
 +	    )
 +	  (when (not (equal (car (cdr actual)) (car (cdr desired))))
 +	    (semantic-ia-utest-log
 +	     "  Failed TNames %d: Actual: %S Desired: %S"
 +	     idx (car (cdr actual)) (car (cdr desired)))
 +	    (semantic-ia-utest-log
 +	     "  Failed Tool: %s" (object-name symref-tool-used))
 +	    )
 +	  (add-to-list 'semantic-ia-utest-error-log-list
 +		       (list (buffer-name) idx)
 +		       )
 +	  ))
 +
 +      (setq idx (1+ idx))
 +      (setq tag nil))
 +
 +    (if fail
 +	(progn
 +	  (semantic-ia-utest-log
 +	   "    Unit tests (symrefs) failed tests")
 +	  )
 +      (semantic-ia-utest-log "    Unit tests (symrefs) passed (%d total)"
 +			     (- idx 1)))
 +
 +    ))
 +
 +(defun semantic-symref-test-count-hits-in-tag ()
 +  "Lookup in the current tag the symbol under point.
 +Then count all the other references to the same symbol within the
 +tag that contains point, and return that."
 +  (interactive)
 +  (let* ((ctxt (semantic-analyze-current-context))
 +	 (target (car (reverse (oref ctxt prefix))))
 +	 (tag (semantic-current-tag))
 +	 (start (current-time))
 +	 (Lcount 0))
 +    (when (semantic-tag-p target)
 +      (semantic-symref-hits-in-region
 +       target (lambda (start end prefix) (setq Lcount (1+ Lcount)))
 +       (semantic-tag-start tag)
 +       (semantic-tag-end tag))
 +      (when (interactive-p)
 +	(message "Found %d occurrences of %s in %.2f seconds"
 +		 Lcount (semantic-tag-name target)
 +		 (semantic-elapsed-time start (current-time))))
 +      Lcount)))
 +
 +(defun semantic-src-utest-buffer-refs ()
 +  "Run a sym-ref counting unit-test pass in the current buffer."
 +
 +  ;; This line will also force the include, scope, and typecache.
 +  (semantic-clear-toplevel-cache)
 +  ;; Force tags to be parsed.
 +  (semantic-fetch-tags)
 +
 +  (let* ((idx 1)
 +	 (start nil)
 +	 (regex-p nil)
 +	 (desired nil)
 +	 (actual nil)
 +	 (pass nil)
 +	 (fail nil)
 +	 ;; Exclude unpredictable system files in the
 +	 ;; header include list.
 +	 (semanticdb-find-default-throttle
 +	  (remq 'system semanticdb-find-default-throttle))
 +	 )
 +    ;; Keep looking for test points until we run out.
 +    (while (save-excursion
 +	     (setq regex-p (concat "//\\s-*@"
 +				   (number-to-string idx)
 +				   "@\\s-+\\(\\w+\\)" ))
 +	     (goto-char (point-min))
 +	     (save-match-data
 +	       (when (re-search-forward regex-p nil t)
 +		 (goto-char (match-beginning 1))
 +		 (setq desired (read (buffer-substring (point) (point-at-eol))))
 +		 (setq start (match-beginning 0))
 +		 (goto-char start)
 +		 (setq actual (semantic-symref-test-count-hits-in-tag))
 +		 start)))
 +
 +      (if (not actual)
 +	  (progn
 +	    (setq fail (cons idx fail))
 +	    (semantic-ia-utest-log
 +	     "  Failed symref count %d: No results." idx)
 +
 +	    (add-to-list 'semantic-ia-utest-error-log-list
 +			 (list (buffer-name) idx)
 +			 )
 +	    )
 +
 +	(if (equal desired actual)
 +	    ;; We passed
 +	    (setq pass (cons idx pass))
 +	  ;; We failed.
 +	  (setq fail (cons idx fail))
 +	  (when (not (equal actual desired))
 +	    (semantic-ia-utest-log
 +	     "  Failed symref count %d: Actual: %S Desired: %S"
 +	     idx actual desired)
 +	    )
 +
 +	  (add-to-list 'semantic-ia-utest-error-log-list
 +		       (list (buffer-name) idx)
 +		       )
 +	  ))
 +
 +      (setq idx (1+ idx))
 +      )
 +
 +    (if fail
 +	(progn
 +	  (semantic-ia-utest-log
 +	   "    Unit tests (symrefs counter) failed tests")
 +	  )
 +      (semantic-ia-utest-log "    Unit tests (symrefs counter) passed (%d total)"
 +			     (- idx 1)))
 +
 +    ))
 +
 +(defun semantic-ia-utest-start-log ()
 +  "Start up a testlog for a run."
 +  ;; Redo w/ CEDET utest framework.
 +  (cedet-utest-log-start "semantic: analyzer tests"))
 +
 +(defun semantic-ia-utest-log (&rest args)
 +  "Log some test results.
 +Pass ARGS to format to create the log message."
 +  ;; Forward to CEDET utest framework.
 +  (apply 'cedet-utest-log args))
 +
 +(provide 'semantic-ia-utest)
 +
 +;;; semantic-ia-utest.el ends here
diff --cc test/manual/cedet/semantic-tests.el
index 179851fafeb,00000000000..bfcba7e6772
mode 100644,000000..100644
--- a/test/manual/cedet/semantic-tests.el
+++ b/test/manual/cedet/semantic-tests.el
@@@ -1,389 -1,0 +1,389 @@@
 +;;; semantic-utest.el --- Miscellaneous Semantic tests.
 +
- ;;; Copyright (C) 2003-2004, 2007-2016 Free Software Foundation, Inc.
++;;; Copyright (C) 2003-2004, 2007-2017 Free Software Foundation, Inc.
 +
 +;; Author: Eric M. Ludlam 
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +
 +;; Originally, there are many test functions scattered among the
 +;; Semantic source files.  This file consolidates them.
 +
 +(require 'data-debug)
 +
 +;;; From semantic-complete
 +
 +(require 'semantic/complete)
 +
 +(defun semantic-complete-test ()
 +  "Test completion mechanisms."
 +  (interactive)
 +  (message "%S"
 +   (semantic-format-tag-prototype
 +    (semantic-complete-read-tag-project "Symbol: "))))
 +
 +;;; From semanticdb-ebrowse
 +
 +(require 'semantic/db-ebrowse)
 +
 +(defun semanticdb-ebrowse-run-tests ()
 +  "Run some tests of the semanticdb-ebrowse system.
 +All systems are different.  Ask questions along the way."
 +  (interactive)
 +  (let ((doload nil))
 +    (when (y-or-n-p "Create a system database to test with? ")
 +      (call-interactively 'semanticdb-create-ebrowse-database)
 +      (setq doload t))
 +    ;;  Should we load in caches
 +    (when (if doload
 +	      (y-or-n-p "New database created.  Reload system databases? ")
 +	    (y-or-n-p "Load in all system databases? "))
 +      (semanticdb-load-ebrowse-caches)))
 +  ;; Ok, databases were created.  Let's try some searching.
 +  (when (not (or (eq major-mode 'c-mode)
 +		 (eq major-mode 'c++-mode)))
 +    (error "Please make your default buffer be a C or C++ file, then
 +run the test again")))
 +
 +(defun semanticdb-ebrowse-dump ()
 +  "Find the first loaded ebrowse table, and dump out the contents."
 +  (interactive)
 +  (let ((db semanticdb-database-list)
 +	(ab nil))
 +    (while db
 +      (when (semanticdb-project-database-ebrowse-p (car db))
 +	(setq ab (data-debug-new-buffer "*EBROWSE Database*"))
 +	(data-debug-insert-thing (car db) "*" "")
 +	(setq db nil)
 +	)
 +      (setq db (cdr db)))))
 +
 +;;; From semanticdb-global:
 +
 +(require 'semantic/db-global)
 +
 +(defvar semanticdb-test-gnu-global-startfile "~/src/global-5.7.3/global/global.c"
 +  "File to use for testing.")
 +
 +(defun semanticdb-test-gnu-global (searchfor &optional standardfile)
 +  "Test the GNU Global semanticdb.
 +Argument SEARCHFOR is the text to search for.
 +If optional arg STANDARDFILE is non-nil, use a standard file w/ global enabled."
 +  (interactive "sSearch For Tag: \nP")
 +
 +  (require 'data-debug)
 +  (save-excursion
 +    (when standardfile
 +      (save-match-data
 +	(set-buffer (find-file-noselect semanticdb-test-gnu-global-startfile))))
 +
 +    (condition-case err
 +	(semanticdb-enable-gnu-global-in-buffer)
 +      (error (if standardfile
 +		 (error err)
 +	       (save-match-data
 +		 (set-buffer (find-file-noselect semanticdb-test-gnu-global-startfile)))
 +	       (semanticdb-enable-gnu-global-in-buffer))))
 +
 +    (let* ((db (semanticdb-project-database-global "global"))
 +	   (tab (semanticdb-file-table db (buffer-file-name)))
 +	   (result (semanticdb-deep-find-tags-for-completion-method tab searchfor))
 +	   )
 +      (data-debug-new-buffer "*SemanticDB Gnu Global Result*")
 +      (data-debug-insert-thing result "?" ""))))
 +
 +;;; From semantic-format
 +
 +(require 'semantic/format)
 +
 +(defun semantic-test-all-format-tag-functions (&optional arg)
 +  "Test all outputs from `semantic-format-tag-functions'.
 +Output is generated from the function under `point'.
 +Optional argument ARG specifies not to use color."
 +  (interactive "P")
 +  (semantic-fetch-tags)
 +  (let* ((tag (semantic-current-tag))
 +	 (par (semantic-current-tag-parent))
 +	 (fns semantic-format-tag-functions))
 +    (with-output-to-temp-buffer "*format-tag*"
 +      (princ "Tag->format function tests:")
 +      (while fns
 +	(princ "\n")
 +	(princ (car fns))
 +	(princ ":\n ")
 +	(let ((s (funcall (car fns) tag par (not arg))))
 +	  (save-excursion
 +	    (set-buffer "*format-tag*")
 +	    (goto-char (point-max))
 +	    (insert s)))
 +	(setq fns (cdr fns))))
 +      ))
 +
 +;;; From semantic-fw:
 +
 +(require 'semantic/fw)
 +
 +(defun semantic-test-data-cache ()
 +  "Test the data cache."
 +  (interactive)
 +  (let ((data '(a b c)))
 +    (save-excursion
 +      (set-buffer (get-buffer-create " *semantic-test-data-cache*"))
 +      (erase-buffer)
 +      (insert "The Moose is Loose")
 +      (goto-char (point-min))
 +      (semantic-cache-data-to-buffer (current-buffer) (point) (+ (point) 5)
 +				     data 'moose 'exit-cache-zone)
 +      (if (equal (semantic-get-cache-data 'moose) data)
 +	  (message "Successfully retrieved cached data.")
 +	(error "Failed to retrieve cached data")))))
 +
 +(defun semantic-test-throw-on-input ()
 +  "Test that throw on input will work."
 +  (interactive)
 +  (semantic-throw-on-input 'done-die)
 +  (message "Exit Code: %s"
 +	   (semantic-exit-on-input 'testing
 +	     (let ((inhibit-quit nil)
 +		   (message-log-max nil))
 +	       (while t
 +		 (message "Looping ... press a key to test")
 +		 (semantic-throw-on-input 'test-inner-loop))
 +	       'exit)))
 +  (when (input-pending-p)
 +    (if (fboundp 'read-event)
 +	(read-event)
 +      (read-char))))
 +
 +;;; From semantic-idle:
 +
 +(require 'semantic/idle)
 +
 +(defun semantic-idle-pnf-test ()
 +  "Test `semantic-idle-scheduler-work-parse-neighboring-files' and time it."
 +  (interactive)
 +  (let ((start (current-time))
 +	(junk (semantic-idle-scheduler-work-parse-neighboring-files))
 +	(end (current-time)))
 +    (message "Work took %.2f seconds." (semantic-elapsed-time start end))))
 +
 +;;; From semantic-lex:
 +
 +(require 'semantic/lex)
 +
 +(defun semantic-lex-test-full-depth (arg)
 +  "Test the semantic lexer in the current buffer parsing through lists.
 +Usually the lexer parses.
 +If universal argument ARG, then try the whole buffer."
 +  (interactive "P")
 +  (let* ((start (current-time))
 +	 (result (semantic-lex
 +		  (if arg (point-min) (point))
 +		  (point-max)
 +		  100))
 +	 (end (current-time)))
 +    (message "Elapsed Time: %.2f seconds."
 +	     (semantic-elapsed-time start end))
 +    (pop-to-buffer "*Lexer Output*")
 +    (require 'pp)
 +    (erase-buffer)
 +    (insert (pp-to-string result))
 +    (goto-char (point-min))))
 +
 +(defun semantic-lex-test-region (beg end)
 +  "Test the semantic lexer in the current buffer.
 +Analyze the area between BEG and END."
 +  (interactive "r")
 +  (let ((result (semantic-lex beg end)))
 +    (pop-to-buffer "*Lexer Output*")
 +    (require 'pp)
 +    (erase-buffer)
 +    (insert (pp-to-string result))
 +    (goto-char (point-min))))
 +
 +;;; From semantic-lex-spp:
 +
 +(require 'semantic/lex-spp)
 +
 +(defun semantic-lex-spp-write-test ()
 +  "Test the semantic tag writer against the current buffer."
 +  (interactive)
 +  (with-output-to-temp-buffer "*SPP Write Test*"
 +    (semantic-lex-spp-table-write-slot-value
 +     (semantic-lex-spp-save-table))))
 +
 +(defun semantic-lex-spp-write-utest ()
 +  "Unit test using the test spp file to test the slot write fcn."
 +  (interactive)
 +  (let* ((sem (locate-library "semantic-lex-spp.el"))
 +	 (dir (file-name-directory sem)))
 +    (save-excursion
 +      (set-buffer (find-file-noselect
 +		   (expand-file-name "tests/testsppreplace.c"
 +				     dir)))
 +      (semantic-lex-spp-write-test))))
 +
 +;;; From semantic-tag-write:
 +
 +;;; TESTING.
 +
 +(require 'semantic/tag-write)
 +
 +(defun semantic-tag-write-test ()
 +  "Test the semantic tag writer against the tag under point."
 +  (interactive)
 +  (with-output-to-temp-buffer "*Tag Write Test*"
 +    (semantic-tag-write-one-tag (semantic-current-tag))))
 +
 +(defun semantic-tag-write-list-test ()
 +  "Test the semantic tag writer against the tag under point."
 +  (interactive)
 +  (with-output-to-temp-buffer "*Tag Write Test*"
 +    (semantic-tag-write-tag-list (semantic-fetch-tags))))
 +
 +;;; From semantic-symref-filter:
 +
 +(require 'semantic/symref/filter)
 +
 +(defun semantic-symref-test-count-hits-in-tag ()
 +  "Lookup in the current tag the symbol under point.
 +Then count all the other references to the same symbol within the
 +tag that contains point, and return that."
 +  (interactive)
 +  (let* ((ctxt (semantic-analyze-current-context))
 +	 (target (car (reverse (oref ctxt prefix))))
 +	 (tag (semantic-current-tag))
 +	 (start (current-time))
 +	 (Lcount 0))
 +    (when (semantic-tag-p target)
 +      (semantic-symref-hits-in-region
 +       target (lambda (start end prefix) (setq Lcount (1+ Lcount)))
 +       (semantic-tag-start tag)
 +       (semantic-tag-end tag))
 +      (when (interactive-p)
 +	(message "Found %d occurrences of %s in %.2f seconds"
 +		 Lcount (semantic-tag-name target)
 +		 (semantic-elapsed-time start (current-time))))
 +      Lcount)))
 +
 +;;; From bovine-gcc:
 +
 +(require 'semantic/bovine/gcc)
 +
 +;; Example output of "gcc -v"
 +(defvar semantic-gcc-test-strings
 +  '(;; My old box:
 +    "Reading specs from /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/specs
 +Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --disable-checking --with-system-zlib --enable-__cxa_atexit --host=i386-redhat-linux
 +Thread model: posix
 +gcc version 3.2.2 20030222 (Red Hat Linux 3.2.2-5)"
 +    ;; Alex Ott:
 +    "Using built-in specs.
 +Target: i486-linux-gnu
 +Configured with: ../src/configure -v --with-pkgversion='Ubuntu 4.3.1-9ubuntu1' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-targets=all --enable-checking=release --build=i486-linux-gnu --host=i486-linux-gnu --target=i486-linux-gnu
 +Thread model: posix
 +gcc version 4.3.1 (Ubuntu 4.3.1-9ubuntu1)"
 +    ;; My debian box:
 +    "Using built-in specs.
 +Target: x86_64-unknown-linux-gnu
 +Configured with: ../../../sources/gcc/configure --prefix=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3 --with-gmp=/usr/local/gcc/gmp --with-mpfr=/usr/local/gcc/mpfr --enable-languages=c,c++,fortran --with-as=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3/bin/as --with-ld=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3/bin/ld --disable-multilib
 +Thread model: posix
 +gcc version 4.2.3"
 +    ;; My mac:
 +    "Using built-in specs.
 +Target: i686-apple-darwin8
 +Configured with: /private/var/tmp/gcc/gcc-5341.obj~1/src/configure --disable-checking -enable-werror --prefix=/usr --mandir=/share/man --enable-languages=c,objc,c++,obj-c++ --program-transform-name=/^[cg][^.-]*$/s/$/-4.0/ --with-gxx-include-dir=/include/c++/4.0.0 --with-slibdir=/usr/lib --build=powerpc-apple-darwin8 --with-arch=pentium-m --with-tune=prescott --program-prefix= --host=i686-apple-darwin8 --target=i686-apple-darwin8
 +Thread model: posix
 +gcc version 4.0.1 (Apple Computer, Inc. build 5341)"
 +    ;; Ubuntu Intrepid
 +    "Using built-in specs.
 +Target: x86_64-linux-gnu
 +Configured with: ../src/configure -v --with-pkgversion='Ubuntu 4.3.2-1ubuntu12' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-checking=release --build=x86_64-linux-gnu --host=x86_64-linux-gnu --target=x86_64-linux-gnu
 +Thread model: posix
 +gcc version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)"
 +    ;; Red Hat EL4
 +    "Reading specs from /usr/lib/gcc/x86_64-redhat-linux/3.4.6/specs
 +Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --disable-checking --with-system-zlib --enable-__cxa_atexit --disable-libunwind-exceptions --enable-java-awt=gtk --host=x86_64-redhat-linux
 +Thread model: posix
 +gcc version 3.4.6 20060404 (Red Hat 3.4.6-10)"
 +    ;; Red Hat EL5
 +    "Using built-in specs.
 +Target: x86_64-redhat-linux
 +Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --enable-checking=release --with-system-zlib --enable-__cxa_atexit --disable-libunwind-exceptions --enable-libgcj-multifile --enable-languages=c,c++,objc,obj-c++,java,fortran,ada --enable-java-awt=gtk --disable-dssi --enable-plugin --with-java-home=/usr/lib/jvm/java-1.4.2-gcj-1.4.2.0/jre --with-cpu=generic --host=x86_64-redhat-linux
 +Thread model: posix
 +gcc version 4.1.2 20080704 (Red Hat 4.1.2-44)"
 +    ;; David Engster's german gcc on ubuntu 4.3
 +    "Es werden eingebaute Spezifikationen verwendet.
 +Ziel: i486-linux-gnu
 +Konfiguriert mit: ../src/configure -v --with-pkgversion='Ubuntu 4.3.2-1ubuntu12' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-targets=all --enable-checking=release --build=i486-linux-gnu --host=i486-linux-gnu --target=i486-linux-gnu
 +Thread-Modell: posix
 +gcc-Version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)"
 +    ;; Damien Deville bsd
 +    "Using built-in specs.
 +Target: i386-undermydesk-freebsd
 +Configured with: FreeBSD/i386 system compiler
 +Thread model: posix
 +gcc version 4.2.1 20070719  [FreeBSD]"
 +    )
 +  "A bunch of sample gcc -v outputs from different machines.")
 +
 +(defvar semantic-gcc-test-strings-fail
 +  '(;; A really old solaris box I found
 +    "Reading specs from /usr/local/gcc-2.95.2/lib/gcc-lib/sparc-sun-solaris2.6/2.95.2/specs
 +gcc version 2.95.2 19991024 (release)"
 +    )
 +  "A bunch of sample gcc -v outputs that fail to provide the info we want.")
 +
 +(defun semantic-gcc-test-output-parser ()
 +  "Test the output parser against some collected strings."
 +  (interactive)
 +  (let ((fail nil))
 +    (dolist (S semantic-gcc-test-strings)
 +      (let* ((fields (semantic-gcc-fields S))
 +             (v (cdr (assoc 'version fields)))
 +             (h (or (cdr (assoc 'target fields))
 +                    (cdr (assoc '--target fields))
 +                    (cdr (assoc '--host fields))))
 +             (p (cdr (assoc '--prefix fields)))
 +             )
 +	;; No longer test for prefixes.
 +        (when (not (and v h))
 +          (let ((strs (split-string S "\n")))
 +            (message "Test failed on %S\nV H P:\n%S %S %S" (car strs) v h p))
 +          (setq fail t))
 +        ))
 +    (dolist (S semantic-gcc-test-strings-fail)
 +      (let* ((fields (semantic-gcc-fields S))
 +             (v (cdr (assoc 'version fields)))
 +             (h (or (cdr (assoc '--host fields))
 +                    (cdr (assoc 'target fields))))
 +             (p (cdr (assoc '--prefix fields)))
 +             )
 +        (when (and v h p)
 +          (message "Negative test failed on %S" S)
 +          (setq fail t))
 +        ))
 +    (if (not fail) (message "Tests passed."))
 +    ))
 +
 +(defun semantic-gcc-test-output-parser-this-machine ()
 +  "Test the output parser against the machine currently running Emacs."
 +  (interactive)
 +  (let ((semantic-gcc-test-strings (list (semantic-gcc-query "gcc" "-v"))))
 +    (semantic-gcc-test-output-parser))
 +  )
diff --cc test/manual/cedet/semantic-utest-c.el
index ec09b96211f,00000000000..26ce4009277
mode 100644,000000..100644
--- a/test/manual/cedet/semantic-utest-c.el
+++ b/test/manual/cedet/semantic-utest-c.el
@@@ -1,72 -1,0 +1,72 @@@
 +;;; semantic-utest-c.el --- C based parsing tests.
 +
- ;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2008-2017 Free Software Foundation, Inc.
 +
 +;; Author: Eric M. Ludlam 
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +;;
 +;; Run some C based parsing tests.
 +
 +(require 'semantic)
 +
 +(defvar semantic-utest-c-comparisons
 +  '( ("testsppreplace.c" . "testsppreplaced.c")
 +     )
 +  "List of files to parse and compare against each other.")
 +
 +;;; Code:
 +;;;###autoload
 +(defun semantic-utest-c ()
 +  "Run parsing test for C from the test directory."
 +  (interactive)
 +  (dolist (fp semantic-utest-c-comparisons)
 +    (let* ((sem (locate-library "semantic"))
 +	   (sdir (file-name-directory sem))
 +	   (semantic-lex-c-nested-namespace-ignore-second nil)
 +	   (tags-actual
 +	    (save-excursion
 +	      (set-buffer (find-file-noselect (expand-file-name (concat "tests/" (car fp)) sdir)))
 +	      (semantic-clear-toplevel-cache)
 +	      (semantic-fetch-tags)))
 +	   (tags-expected
 +	    (save-excursion
 +	      (set-buffer (find-file-noselect (expand-file-name (concat "tests/" (cdr fp)) sdir)))
 +	      (semantic-clear-toplevel-cache)
 +	      (semantic-fetch-tags))))
 +      ;; Now that we have the tags, compare them for SPP accuracy.
 +      (dolist (tag tags-actual)
 +	(if (and (semantic-tag-of-class-p tag 'variable)
 +		 (semantic-tag-variable-constant-p tag))
 +	    nil				; skip the macros.
 +	  (if (semantic-tag-similar-with-subtags-p tag (car tags-expected))
 +	      (setq tags-expected (cdr tags-expected))
 +	    (with-mode-local c-mode
 +	      (error "Found: >> %s << Expected: >>  %s <<"
 +		     (semantic-format-tag-prototype tag nil t)
 +		     (semantic-format-tag-prototype (car tags-expected) nil t)
 +		     )))
 +	  ))
 +      ;; Passed?
 +      (message "PASSED!")
 +      )))
 +
 +
 +(provide 'semantic-utest-c)
 +
 +;;; semantic-utest-c.el ends here
diff --cc test/manual/cedet/semantic-utest.el
index d26d6118d2d,00000000000..f735e552413
mode 100644,000000..100644
--- a/test/manual/cedet/semantic-utest.el
+++ b/test/manual/cedet/semantic-utest.el
@@@ -1,867 -1,0 +1,867 @@@
 +;;; semantic-utest.el --- Tests for semantic's parsing system.
 +
- ;;; Copyright (C) 2003-2004, 2007-2016 Free Software Foundation, Inc.
++;;; Copyright (C) 2003-2004, 2007-2017 Free Software Foundation, Inc.
 +
 +;; Author: Eric M. Ludlam 
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +;;
 +;; Semantic's parsing and partial parsing system is pretty complex.
 +;; These unit tests attempt to emulate semantic's partial reparsing
 +;; and full reparsing system, and anything else I may feel the urge
 +;; to write a test for.
 +
 +(require 'semantic)
 +
 +(load-file "cedet-utests.el")
 +
 +(defvar semantic-utest-temp-directory (if (fboundp 'temp-directory)
 +					  (temp-directory)
 +					temporary-file-directory)
 +  "Temporary directory to use when creating files.")
 +
 +(defun semantic-utest-fname (name)
 +  "Create a filename for NAME in /tmp."
 +  (expand-file-name name semantic-utest-temp-directory))
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;; Data for C tests
 +
 +(defvar semantic-utest-C-buffer-contents
 +  "/* Test file for C language for Unit Tests */
 +
 +#include 
 +#include \"sutest.h\"
 +
 +struct mystruct1 {
 +  int slot11;
 +  char slot12;
 +  float slot13;
 +};
 +
 +int var1;
 +
 +float funp1(char arg11, char arg12);
 +
 +char fun2(int arg_21, int arg_22) /*1*/
 +{
 +  struct mystruct1 *ms1 = malloc(sizeof(struct mystruct1));
 +
 +  char sv = calc_sv(var1);
 +
 +  if (var1 == 0) {
 +     sv = 1;
 +  } else if (arg_21 == 0) {
 +     sv = 2;
 +  } else if (arg_22 == 0) {
 +     sv = 3;
 +  } else {
 +     sv = 4;
 +  }
 +
 +  printf(\"SV = %d\\n\", sv);
 +
 +  /* Memory Leak */
 +  ms1.slot1 = sv;
 +
 +  return 'A' + sv;
 +}
 +"
 +  "Contents of a C buffer initialized by this unit test.
 +Be sure to change `semantic-utest-C-name-contents' when you
 +change this variable.")
 +
 +(defvar semantic-utest-C-h-buffer-contents
 +  "/* Test file for C language header file for Unit Tests */
 +
 +int calc_sv(int);
 +
 +"
 +  "Contents of a C header file buffer initialized by this unit test.")
 +
 +(defvar semantic-utest-C-filename (semantic-utest-fname "sutest.c")
 +  "File to open and erase during this test for C.")
 +
 +(defvar semantic-utest-C-filename-h
 +  (concat (file-name-sans-extension semantic-utest-C-filename)
 +	  ".h")
 +  "Header file filename for C")
 +
 +
 +(defvar semantic-utest-C-name-contents
 +  '(("stdio.h" include
 +     (:system-flag t)
 +     nil (overlay 48 66 "sutest.c"))
 +    ("sutest.h" include nil nil (overlay 67 86 "sutest.c"))
 +    ("mystruct1" type
 +     (:members
 +      (("slot11" variable
 +	(:type "int")
 +	(reparse-symbol classsubparts)
 +	(overlay 109 120 "sutest.c"))
 +       ("slot12" variable
 +	(:type "char")
 +	(reparse-symbol classsubparts)
 +	(overlay 123 135 "sutest.c"))
 +       ("slot13" variable
 +	(:type "float")
 +	(reparse-symbol classsubparts)
 +	(overlay 138 151 "sutest.c")))
 +      :type "struct")
 +     nil (overlay 88 154 "sutest.c"))
 +    ("var1" variable
 +     (:type "int")
 +     nil (overlay 156 165 "sutest.c"))
 +    ("funp1" function
 +     (:prototype-flag t :arguments
 +		      (("arg11" variable
 +			(:type "char")
 +			(reparse-symbol arg-sub-list)
 +			(overlay 179 190 "sutest.c"))
 +		       ("arg12" variable
 +			(:type "char")
 +			(reparse-symbol arg-sub-list)
 +			(overlay 191 202 "sutest.c")))
 +		      :type "float")
 +     nil (overlay 167 203 "sutest.c"))
 +    ("fun2" function
 +     (:arguments
 +      (("arg_21" variable
 +	(:type "int")
 +	(reparse-symbol arg-sub-list)
 +	(overlay 215 226 "sutest.c"))
 +       ("arg_22" variable
 +	(:type "int")
 +	(reparse-symbol arg-sub-list)
 +	(overlay 227 238 "sutest.c")))
 +      :type "char")
 +     nil (overlay 205 566 "sutest.c")))
 +  "List of expected tag names for C.")
 +
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;; Data for Python tests
 +
 +(defvar semantic-utest-Python-buffer-contents
 +"
 +def fun1(a,b,c):
 +  return a
 +
 +def fun2(a,b,c): #1
 +  return b
 +
 +"
 +
 +
 +)
 +;  "python test case. notice that python is indentation sensitive
 +
 +
 +(defvar semantic-utest-Python-name-contents
 +  '(("fun1" function
 +     (:arguments
 +      (("a" variable nil
 +        (reparse-symbol function_parameters)
 +	(overlay 10 11 "tst.py"))
 +       ("b" variable nil
 +        (reparse-symbol function_parameters)
 +        (overlay 12 13 "tst.py"))
 +       ("c" variable nil
 +        (reparse-symbol function_parameters)
 +        (overlay 14 15 "tst.py"))))
 +     nil (overlay 1 31 "tst.py"))
 +    ("fun2" function
 +     (:arguments
 +      (("a" variable nil
 +        (reparse-symbol function_parameters)
 +        (overlay 41 42 "tst.py"))
 +       ("b" variable nil
 +        (reparse-symbol function_parameters)
 +        (overlay 43 44 "tst.py"))
 +       ("c" variable nil
 +        (reparse-symbol function_parameters)
 +        (overlay 45 46 "tst.py"))))
 +     nil (overlay 32 65 "tst.py")))
 +
 +  "List of expected tag names for Python.")
 +
 +
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;; Data for Java tests
 +
 +(defvar semantic-utest-Java-buffer-contents
 +"
 +class JavaTest{
 +  void fun1(int a,int b){
 +    return a;
 +  }
 +
 +  void fun2(int a,int b){ //1
 +    return b;
 +  }
 +
 +}
 +"
 +)
 +
 +(defvar semantic-utest-Java-name-contents
 +  '(("JavaTest" type
 +     (:members
 +      (("fun1" function
 +        (:arguments
 +         (("a" variable
 +           (:type "int")
 +           (reparse-symbol formal_parameters)
 +           (overlay 30 35 "JavaTest.java"))
 +	  ("b" variable
 +	   (:type "int")
 +	   (reparse-symbol formal_parameters)
 +	   (overlay 36 41 "JavaTest.java")))
 +         :type "void")
 +        (reparse-symbol class_member_declaration)
 +        (overlay 20 61 "JavaTest.java"))
 +       ("fun2" function
 +	(:arguments
 +	 (("a" variable
 +	   (:type "int")
 +	   (reparse-symbol formal_parameters)
 +	   (overlay 75 80 "JavaTest.java"))
 +	  ("b" variable
 +	   (:type "int")
 +	   (reparse-symbol formal_parameters)
 +	   (overlay 81 86 "JavaTest.java")))
 +	 :type "void")
 +	(reparse-symbol class_member_declaration)
 +	(overlay 65 110 "JavaTest.java")))
 +      :type "class")
 +     nil (overlay 2 113 "JavaTest.java")))
 +  "List of expected tag names for Java."
 +  )
 +
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;; Data for Javascript tests
 +
 +(defvar semantic-utest-Javascript-buffer-contents
 +"
 +function fun1(a, b){
 +    return a;
 +  }
 +
 +function fun2(a,b){ //1
 +    return b;
 +  }
 +"
 +)
 +
 +
 +(defvar semantic-utest-Javascript-name-contents
 +  '(("fun1" function
 +     (:arguments
 +      (("a" variable nil
 +	(reparse-symbol FormalParameterList)
 +	(overlay 15 16 "tst.js"))
 +       ("b" variable nil
 +	(reparse-symbol FormalParameterList)
 +	(overlay 18 19 "tst.js"))))
 +     nil (overlay 1 39 "tst.js"))
 +    ("fun2" function
 +     (:arguments
 +      (("a" variable nil
 +	(reparse-symbol FormalParameterList)
 +	(overlay 55 56 "tst.js"))
 +       ("b" variable nil
 +	(reparse-symbol FormalParameterList)
 +	(overlay 57 58 "tst.js"))))
 +     nil (overlay 41 82 "tst.js")))
 +
 +  "List of expected tag names for Javascript.")
 +
 +
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;; Data for Makefile tests
 +
 +(defvar semantic-utest-Makefile-buffer-contents
 +"
 +t1:
 +\techo t1
 +
 +t2:t1 #1
 +\techo t2
 +
 +
 +"
 +)
 +
 +
 +(defvar semantic-utest-Makefile-name-contents
 +  '(("t1" function nil nil (overlay 1 9 "Makefile"))
 +    ("t2" function
 +     (:arguments
 +      ("t1"))
 +     nil (overlay 18 28 "Makefile")))
 +  "List of expected tag names for Makefile.")
 +
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;; Data for Scheme tests
 +
 +(defvar semantic-utest-Scheme-buffer-contents
 +  "
 + (define fun1 2)
 +
 + (define fun2 3  ;1
 +              )
 +")
 +
 +(defvar semantic-utest-Scheme-name-contents
 +  '(("fun1" variable
 +     (:default-value ("2"))
 +     nil (overlay 3 18 "tst.scm"))
 +    ("fun2" variable
 +     (:default-value ("3"))
 +     nil (overlay 21 55 "tst.scm")))
 +  )
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;; Data for Html tests
 +
 +(defvar semantic-utest-Html-buffer-contents
 +  "
 +
 +  
 +    
    hello
    
 +  
 +
 +"
 +  )
 +
 +(defvar semantic-utest-Html-name-contents
 +  '(("hello" section
 +     (:members
 +      (("hello" section nil nil (overlay 21 24 "tst.html"))))
 +     nil (overlay 10 15 "tst.html")))
 +  )
 +
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;; Data for PHP tests
 +
 +(defvar semantic-utest-PHP-buffer-contents
 +  " "
 +  )
 +
 +(defvar semantic-utest-PHP-name-contents
 +  '(("fun1" function nil
 +     nil (overlay 9 45 "phptest.php"))
 +    ("fun2" function
 +     (:arguments (("$arg1" variable nil (reparse-symbol formal_parameters) (overlay 61 66 "phptest.php"))))
 +     nil
 +     (overlay 47 132 "phptest.php"))
 +    ("aClass" type
 +     (:members (("fun1" function
 +		 (:typemodifiers ("public") :arguments
 +				 (("$a" variable nil (reparse-symbol formal_parameters) (overlay 174 176 "phptest.php"))
 +				  ("$b" variable nil (reparse-symbol formal_parameters) (overlay 178 180 "phptest.php"))))
 +
 +		 nil
 +		 (overlay 153 204 "phptest.php"))
 +
 +		("fun2" function
 +		 (:typemodifiers ("public") :arguments
 +				 (("$a" variable nil (reparse-symbol formal_parameters) (overlay 230 232 "phptest.php"))
 +				  ("$b" variable nil (reparse-symbol formal_parameters) (overlay 234 236 "phptest.php"))
 +				  ))
 +		 nil
 +		 (overlay 209 260 "phptest.php"))) :type "class")
 +     nil
 +     (overlay 135 262 "phptest.php"))
 +    )
 +  "Expected results from the PHP Unit test"
 +  )
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;; Data for Csharp C# tests
 +
 +(defvar semantic-utest-Csharp-buffer-contents
 +"
 +class someClass {
 +  int fun1(int a, int b) {
 +    return a; }
 +  int fun2(int a, int b) {
 +    return b; }
 +}
 +")
 +
 +(defvar semantic-utest-Csharp-name-contents
 +  '(("someClass" type
 +     (:members
 +      (("fun1" function
 +	(:arguments
 +	 (("a" variable
 +	   (:type "int")
 +	   (reparse-symbol formal_parameters)
 +	   (overlay 30 35 "tst.cs"))
 +	  ("b" variable
 +	   (:type "int")
 +	   (reparse-symbol formal_parameters)
 +	   (overlay 37 42 "tst.cs")))
 +	 :type "int")
 +	(reparse-symbol class_member_declaration)
 +	(overlay 21 61 "tst.cs"))
 +       ("fun2" function
 +	(:arguments
 +	 (("a" variable
 +	   (:type "int")
 +	   (reparse-symbol formal_parameters)
 +	   (overlay 73 78 "tst.cs"))
 +	  ("b" variable
 +	   (:type "int")
 +	   (reparse-symbol formal_parameters)
 +	   (overlay 80 85 "tst.cs")))
 +	 :type "int")
 +	(reparse-symbol class_member_declaration)
 +	(overlay 64 104 "tst.cs")))
 +      :type "class")
 +     nil (overlay 1 106 "tst.cs")))
 +  )
 +
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +
 +
 +
 +(defun semantic-utest-makebuffer (filename contents)
 +  "Create a buffer for FILENAME for use in a unit test.
 +Pre-fill the buffer with CONTENTS."
 +  (let ((buff (semantic-find-file-noselect filename)))
 +    (set-buffer buff)
 +    (setq buffer-offer-save nil)
 +    (font-lock-mode -1) ;; Font lock has issues in Emacs 23
 +    (toggle-read-only -1) ;; In case /tmp doesn't exist.
 +    (erase-buffer)
 +    (insert contents)
 +    ;(semantic-fetch-tags) ;JAVE could this go here?
 +    (set-buffer-modified-p nil)
 +    buff
 +    )
 +  )
 +
 +(defun semantic-utest-C ()
 +  "Run semantic's C unit test."
 +  (interactive)
 +  (save-excursion
 +    (let ((buff  (semantic-utest-makebuffer semantic-utest-C-filename   semantic-utest-C-buffer-contents))
 +	  (buff2 (semantic-utest-makebuffer semantic-utest-C-filename-h semantic-utest-C-h-buffer-contents))
 +	  )
 +      (semantic-fetch-tags)
 +      (set-buffer buff)
 +
 +      ;; Turn off a range of modes
 +      (semantic-idle-scheduler-mode -1)
 +
 +      ;; Turn on some modes
 +      (semantic-highlight-edits-mode 1)
 +
 +      ;; Update tags, and show it.
 +      (semantic-fetch-tags)
 +
 +      (switch-to-buffer buff)
 +      (sit-for 0)
 +
 +      ;; Run the tests.
 +      ;;(message "First parsing test.")
 +      (semantic-utest-verify-names semantic-utest-C-name-contents)
 +
 +      ;;(message "Invalid tag test.")
 +      (semantic-utest-last-invalid semantic-utest-C-name-contents '("fun2") "/\\*1\\*/" "/* Deleted this line */")
 +      (semantic-utest-verify-names semantic-utest-C-name-contents)
 +
 +      (set-buffer-modified-p nil)
 +      ;; Clean up
 +      ;; (kill-buffer buff)
 +      ;; (kill-buffer buff2)
 +      ))
 +  (message "All C tests passed.")
 +  )
 +
 +
 +
 +
 +(defun semantic-utest-generic (testname filename contents name-contents names-removed killme insertme)
 +  "Generic unit test according to template.
 +Should work for languages without .h files, python javascript java.
 +TESTNAME is the name of the test.
 +FILENAME is the name of the file to create.
 +CONTENTS is the contents of the file to test.
 +NAME-CONTENTS is the list of names that should be in the contents.
 +NAMES-REMOVED is the list of names that gets removed in the removal step.
 +KILLME is the name of items to be killed.
 +INSERTME is the text to be inserted after the deletion."
 +  (save-excursion
 +    (let ((buff  (semantic-utest-makebuffer filename  contents))
 +	  )
 +      ;; Turn off a range of modes
 +      (semantic-idle-scheduler-mode -1)
 +
 +      ;; Turn on some modes
 +      (semantic-highlight-edits-mode 1)
 +
 +      ;; Update tags, and show it.
 +      (semantic-fetch-tags)
 +      (switch-to-buffer buff)
 +      (sit-for 0)
 +
 +      ;; Run the tests.
 +      ;;(message "First parsing test %s." testname)
 +      (semantic-utest-verify-names name-contents)
 +
 +      ;;(message "Invalid tag test %s." testname)
 +      (semantic-utest-last-invalid name-contents names-removed killme insertme)
 +      (semantic-utest-verify-names name-contents)
 +
 +      (set-buffer-modified-p nil)
 +      ;; Clean up
 +      ;; (kill-buffer buff)
 +      ))
 +  (message "All %s tests passed." testname)
 +  )
 +
 +(defun semantic-utest-Python()
 +  (interactive)
 +  (if (fboundp 'python-mode)
 +      (semantic-utest-generic "Python" (semantic-utest-fname "pytest.py") semantic-utest-Python-buffer-contents  semantic-utest-Python-name-contents   '("fun2") "#1" "#deleted line")
 +    (message "Skilling Python test: NO major mode."))
 +  )
 +
 +
 +(defun semantic-utest-Javascript()
 +  (interactive)
 +  (if (fboundp 'javascript-mode)
 +      (semantic-utest-generic "Javascript" (semantic-utest-fname "javascripttest.js") semantic-utest-Javascript-buffer-contents  semantic-utest-Javascript-name-contents   '("fun2") "//1" "//deleted line")
 +    (message "Skipping JavaScript test: NO major mode."))
 +  )
 +
 +(defun semantic-utest-Java()
 +  (interactive)
 +  ;; If JDE is installed, it might mess things up depending on the version
 +  ;; that was installed.
 +  (let ((auto-mode-alist  '(("\\.java\\'" . java-mode))))
 +    (semantic-utest-generic "Java" (semantic-utest-fname "JavaTest.java") semantic-utest-Java-buffer-contents  semantic-utest-Java-name-contents   '("fun2") "//1" "//deleted line")
 +    ))
 +
 +(defun semantic-utest-Makefile()
 +  (interactive)
 +  (semantic-utest-generic "Makefile" (semantic-utest-fname "Makefile") semantic-utest-Makefile-buffer-contents  semantic-utest-Makefile-name-contents   '("fun2") "#1" "#deleted line")
 +  )
 +
 +(defun semantic-utest-Scheme()
 +  (interactive)
 +  (semantic-utest-generic "Scheme" (semantic-utest-fname "tst.scm") semantic-utest-Scheme-buffer-contents  semantic-utest-Scheme-name-contents   '("fun2") ";1" ";deleted line")
 +  )
 +
 +
 +(defun semantic-utest-Html()
 +  (interactive)
 +  ;; Disable html-helper auto-fill-in mode.
 +  (let ((html-helper-build-new-buffer nil))
 +    (semantic-utest-generic "HTML" (semantic-utest-fname "tst.html") semantic-utest-Html-buffer-contents  semantic-utest-Html-name-contents   '("fun2") "" "")
 +    ))
 +
 +(defun semantic-utest-PHP()
 +  (interactive)
 +  (if (fboundp 'php-mode)
 +      (semantic-utest-generic "PHP" (semantic-utest-fname "phptest.php") semantic-utest-PHP-buffer-contents semantic-utest-PHP-name-contents '("fun1") "fun2" "%^@")
 +    (message "Skipping PHP Test.  No php-mode loaded."))
 +  )
 +
 +;look at http://mfgames.com/linux/csharp-mode
 +(defun semantic-utest-Csharp() ;; hmm i don't even know how to edit a scharp file. need a csharp mode implementation i suppose
 +  (interactive)
 +  (if (fboundp 'csharp-mode)
 +      (semantic-utest-generic "C#" (semantic-utest-fname "csharptest.cs") semantic-utest-Csharp-buffer-contents  semantic-utest-Csharp-name-contents   '("fun2") "//1" "//deleted line")
 +    (message "Skipping C# test.  No csharp-mode loaded."))
 +  )
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;; stubs
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +; stuff for Erlang
 +;;-module(hello).
 +;-export([hello_world/0]).
 +;
 +;hello_world()->
 +;    io:format("Hello World ~n").
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +;(defun semantic-utest-Erlang()
 +;  (interactive)
 +;  (semantic-utest-generic "Erlang" (semantic-utest-fname "tst.erl") semantic-utest-Erlang-buffer-contents  semantic-utest-Erlang-name-contents   '("fun2") "//1" "//deleted line")
 +;  )
 +;
 +;;texi is also supported
 +;(defun semantic-utest-Texi()
 +;  (interactive)
 +;  (semantic-utest-generic "texi" (semantic-utest-fname "tst.texi") semantic-utest-Texi-buffer-contents  semantic-utest-Texi-name-contents   '("fun2") "//1" "//deleted line")
 +;  )
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 +
 +;;;###autoload
 +(defun semantic-utest-main()
 +  (interactive)
 +  "call all utests"
 +  (cedet-utest-log-start "multi-lang parsing")
 +  (cedet-utest-log " * C tests...")
 +  (semantic-utest-C)
 +  (cedet-utest-log " * Python tests...")
 +  (semantic-utest-Python)
 +  (cedet-utest-log " * Java tests...")
 +  (semantic-utest-Java)
 +  (cedet-utest-log " * Javascript tests...")
 +  (semantic-utest-Javascript)
 +  (cedet-utest-log " * Makefile tests...")
 +  (semantic-utest-Makefile)
 +  (cedet-utest-log " * Scheme tests...")
 +  (semantic-utest-Scheme)
 +  (cedet-utest-log " * Html tests...")
 +  (semantic-utest-Html)
 +  (cedet-utest-log " * PHP tests...")
 +  (semantic-utest-PHP)
 +  (cedet-utest-log " * Csharp tests...")
 +  (semantic-utest-Csharp)
 +
 +  (cedet-utest-log-shutdown "multi-lang parsing")
 +  )
 +
 +;;; Buffer contents validation
 +;;
 +(defun semantic-utest-match-attributes (attr1 attr2 skipnames)
 +  "Compare attribute lists ATTR1 and ATTR2.
 +Argument SKIPNAMES is a list of names that may be child nodes to skip."
 +  (let ((res t))
 +    (while (and res attr1 attr2)
 +
 +      ;; Compare
 +      (setq res
 +	    (cond ((and (listp (car attr1))
 +			(semantic-tag-p (car (car attr1))))
 +		   ;; Compare the list of tags...
 +		   (semantic-utest-taglists-equivalent-p
 +		    (car attr2) (car attr1) skipnames)
 +		   )
 +		  (t
 +		   (equal (car attr1) (car attr2)))))
 +
 +      (if (not res)
 +	  (error "TAG INTERNAL DIFF: %S %S"
 +		 (car attr1) (car attr2)))
 +
 +      (setq attr1 (cdr attr1)
 +	    attr2 (cdr attr2)))
 +    res))
 +
 +(defun semantic-utest-equivalent-tag-p (tag1 tag2 skipnames)
 +  "Determine if TAG1 and TAG2 are the same.
 +SKIPNAMES includes lists of possible child nodes that should be missing."
 +  (and (equal (semantic-tag-name tag1) (semantic-tag-name tag2))
 +       (semantic-tag-of-class-p tag1 (semantic-tag-class tag2))
 +       (semantic-utest-match-attributes
 +	(semantic-tag-attributes tag1) (semantic-tag-attributes tag2)
 +	skipnames)
 +       ))
 +
 +(defun semantic-utest-taglists-equivalent-p (table names skipnames)
 +  "Compare TABLE and NAMES, where skipnames allow list1 to be different.
 +SKIPNAMES is a list of names that should be skipped in the NAMES list."
 +  (let ((SN skipnames))
 +    (while SN
 +      (setq names (remove (car SN) names))
 +      (setq SN (cdr SN))))
 +  (while (and names table)
 +    (if (not (semantic-utest-equivalent-tag-p (car names)
 +					      (car table)
 +					      skipnames))
 +	(error "Expected %s, found %s"
 +	       (semantic-format-tag-prototype (car names))
 +	       (semantic-format-tag-prototype (car table))))
 +    (setq names (cdr names)
 +	  table (cdr table)))
 +  (when names (error "Items forgotten: %S"
 +		     (mapcar 'semantic-tag-name names)
 +		     ))
 +  (when table (error "Items extra: %S"
 +		     (mapcar 'semantic-tag-name table)))
 +  t)
 +
 +(defun semantic-utest-verify-names (name-contents &optional skipnames)
 +  "Verify the names of the test buffer from NAME-CONTENTS.
 +Argument SKIPNAMES is a list of names that should be skipped
 +when analyzing the file.
 +
 +JAVE this thing would need to be recursive to handle java and csharp"
 +  (let ((names name-contents)
 +	(table (semantic-fetch-tags))
 +	)
 +    (semantic-utest-taglists-equivalent-p table names skipnames)
 +    ))
 +
 +;;;;;;;;;;;;;;;;;;;;;;;;
 +; JAVE redefine a  new validation function
 +; is not quite as good as the old one yet
 +(defun semantic-utest-verify-names-jave (name-contents &optional skipnames)
 +  "JAVE version of `semantic-utest-verify-names'.
 +NAME-CONTENTS is a sample of the tags buffer to test against.
 +SKIPNAMES is a list of names to remove from NAME-CONTENTS"
 + (assert (semantic-utest-verify-names-2 name-contents (semantic-fetch-tags))
 +	 nil "failed test")
 +)
 +
 +(defun semantic-utest-verify-names-2 (l1 l2)
 +  (cond   ( (and (consp l1) (equal (car l1) 'overlay))
 +            (overlayp l2))
 +          ((not (consp l1))
 +           (equal l1 l2))
 +          ((consp l1)
 +           (and (semantic-utest-verify-names-2 (car l1) (car l2)) (semantic-utest-verify-names-2 (cdr l1) (cdr l2))))
 +          (t (error "internal error"))))
 +
 +
 +
 +
 +
 +;;; Kill indicator line
 +;;
 +(defvar semantic-utest-last-kill-text nil
 +  "The text from the last kill.")
 +
 +(defvar semantic-utest-last-kill-pos nil
 +  "The position of the last kill.")
 +
 +(defun semantic-utest-kill-indicator ( killme insertme)
 +  "Kill the line with KILLME on it and insert INSERTME in its place."
 +  (goto-char (point-min))
 +;  (re-search-forward (concat "/\\*" indicator "\\*/")); JAVE this isn't generic enough for different languages
 +  (re-search-forward killme)
 +  (beginning-of-line)
 +  (setq semantic-utest-last-kill-pos (point))
 +  (setq semantic-utest-last-kill-text
 +	(buffer-substring (point) (point-at-eol)))
 +  (delete-region (point) (point-at-eol))
 +  (insert insertme)
 +  (sit-for 0)
 +)
 +
 +(defun semantic-utest-unkill-indicator ()
 +  "Unkill the last indicator."
 +  (goto-char semantic-utest-last-kill-pos)
 +  (delete-region (point) (point-at-eol))
 +  (insert semantic-utest-last-kill-text)
 +  (sit-for 0)
 +  )
 +
 +;;;  EDITING TESTS
 +;;
 +
 +(defun semantic-utest-last-invalid (name-contents names-removed killme insertme)
 +  "Make the last fcn invalid."
 +  (semantic-utest-kill-indicator killme insertme)
 +;  (semantic-utest-verify-names name-contents names-removed); verify its gone ;new validator doesn't handle skipnames yet
 +  (semantic-utest-unkill-indicator);put back killed stuff
 +  )
 +
 +
 +
 +
 +;"#]*\\)>"
 +;#]*\)>
 +;(overlay \1 \2 "\3")
 +
 +
 +;; JAVE
 +;; these are some unit tests for cedet that I got from Eric and modified a bit for:
 +;;   python
 +;;   javascript
 +;;   java
 +;; I tried to generalize the structure of the tests a bit to make it easier to add languages
 +
 +;; Mail from Eric:
 +;; Many items in the checklist look like:
 +
 +;;       M-x global-semantic-highlight-edits-mode RET
 +;;       - Edit a file.  See the highlight of newly inserted text.
 +;;       - Customize `semantic-edits-verbose-flag' to be non-nil.
 +;;       - Wait for the idle scheduler, it should clean up the edits.
 +;;         - observe messages from incremental parser.  Do they relate
 +;; 	  to the edits?
 +;;       - M-x bovinate RET - verify your changes are reflected.
 +
 +;; It's all about watching the behavior.  Timers go off, things get
 +;; cleaned up, you type in new changes, etc.  An example I tried to
 +;; do is below, but covers only 1 language, and not very well at that.
 +;; I seem to remember seeing a unit test framework going by one of the
 +;; lists.  I'm not sure if that would help.
 +
 +;; Another that might be automatable:
 +
 +;;       M-x semantic-analyze-current-context RET
 +;;        - Do this in different contexts in your language
 +;;          files.   Verify that reasonable results are returned
 +;;          such as identification of assignments, function arguments, etc.
 +
 +;; Anyway, those are some ideas.  Any effort you put it will be helpful!
 +
 +;; Thanks
 +;; Eric
 +
 +;; -----------
 +
 +
 +
 +;;; semantic-utest.el ends here
diff --cc test/manual/cedet/srecode-tests.el
index 18beb9291fa,00000000000..36256a70597
mode 100644,000000..100644
--- a/test/manual/cedet/srecode-tests.el
+++ b/test/manual/cedet/srecode-tests.el
@@@ -1,296 -1,0 +1,296 @@@
 +;;; srecode-tests.el --- Some tests for CEDET's srecode
 +
- ;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2008-2017 Free Software Foundation, Inc.
 +
 +;; Author: Eric M. Ludlam 
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Commentary:
 +
 +;; Extracted from srecode-fields.el and srecode-document.el in the
 +;; CEDET distribution.
 +
 +;;; Code:
 +
 +;;; From srecode-fields:
 +
 +(require 'srecode/fields)
 +
 +(defvar srecode-field-utest-text
 +  "This is a test buffer.
 +
 +It is filled with some text."
 +  "Text for tests.")
 +
 +(defun srecode-field-utest ()
 +  "Test the srecode field manager."
 +  (interactive)
 +  (if (featurep 'xemacs)
 +      (message "There is no XEmacs support for SRecode Fields.")
 +    (srecode-field-utest-impl)))
 +
 +(defun srecode-field-utest-impl ()
 +  "Implementation of the SRecode field utest."
 +  (save-excursion
 +    (find-file "/tmp/srecode-field-test.txt")
 +
 +    (erase-buffer)
 +    (goto-char (point-min))
 +    (insert srecode-field-utest-text)
 +    (set-buffer-modified-p nil)
 +
 +    ;; Test basic field generation.
 +    (let ((srecode-field-archive nil)
 +	  (f nil))
 +
 +      (end-of-line)
 +      (forward-word -1)
 +
 +      (setq f (srecode-field "Test"
 +			     :name "TEST"
 +			     :start 6
 +			     :end 8))
 +
 +      (when (or (not (slot-boundp f 'overlay)) (not (oref f overlay)))
 +	(error "Field test: Overlay info not created for field"))
 +
 +      (when (and (overlay-p (oref f overlay))
 +		 (not (overlay-get (oref f overlay) 'srecode-init-only)))
 +	(error "Field creation overlay is not tagged w/ init flag"))
 +
 +      (srecode-overlaid-activate f)
 +
 +      (when (or (not (overlay-p (oref f overlay)))
 +		(overlay-get (oref f overlay) 'srecode-init-only))
 +	(error "New field overlay not created during activation"))
 +
 +      (when (not (= (length srecode-field-archive) 1))
 +	(error "Field test: Incorrect number of elements in the field archive"))
 +      (when (not (eq f (car srecode-field-archive)))
 +	(error "Field test: Field did not auto-add itself to the field archive"))
 +
 +      (when (not (overlay-get (oref f overlay) 'keymap))
 +	(error "Field test: Overlay keymap not set"))
 +
 +      (when (not (string= "is" (srecode-overlaid-text f)))
 +	(error "Field test: Expected field text 'is', not %s"
 +	       (srecode-overlaid-text f)))
 +
 +      ;; Test deletion.
 +      (srecode-delete f)
 +
 +      (when (slot-boundp f 'overlay)
 +	(error "Field test: Overlay not deleted after object delete"))
 +      )
 +
 +    ;; Test basic region construction.
 +    (let* ((srecode-field-archive nil)
 +	   (reg nil)
 +	   (fields
 +	    (list
 +	     (srecode-field "Test1" :name "TEST-1" :start 5 :end 10)
 +	     (srecode-field "Test2" :name "TEST-2" :start 15 :end 20)
 +	     (srecode-field "Test3" :name "TEST-3" :start 25 :end 30)
 +
 +	     (srecode-field "Test4" :name "TEST-4" :start 35 :end 35))
 +	    ))
 +
 +      (when (not (= (length srecode-field-archive) 4))
 +	(error "Region Test: Found %d fields.  Expected 4"
 +	       (length srecode-field-archive)))
 +
 +      (setq reg (srecode-template-inserted-region "REG"
 +						  :start 4
 +						  :end 40))
 +
 +      (srecode-overlaid-activate reg)
 +
 +      ;; Make sure it was cleared.
 +      (when srecode-field-archive
 +	(error "Region Test: Did not clear field archive"))
 +
 +      ;; Auto-positioning.
 +      (when (not (eq (point) 5))
 +	(error "Region Test: Did not reposition on first field"))
 +
 +      ;; Active region
 +      (when (not (eq (srecode-active-template-region) reg))
 +	(error "Region Test: Active region not set"))
 +
 +      ;; Various sizes
 +      (mapc (lambda (T)
 +	      (if (string= (object-name-string T) "Test4")
 +		  (progn
 +		    (when (not (srecode-empty-region-p T))
 +		      (error "Field %s is not empty"
 +			     (object-name T)))
 +		    )
 +		(when (not (= (srecode-region-size T) 5))
 +		  (error "Calculated size of %s was not 5"
 +			 (object-name T)))))
 +	    fields)
 +
 +      ;; Make sure things stay up after a 'command'.
 +      (srecode-field-post-command)
 +      (when (not (eq (srecode-active-template-region) reg))
 +	(error "Region Test: Active region did not stay up"))
 +
 +      ;; Test field movement.
 +      (when (not (eq (srecode-overlaid-at-point 'srecode-field)
 +		     (nth 0 fields)))
 +	(error "Region Test: Field %s not under point"
 +	       (object-name (nth 0 fields))))
 +
 +      (srecode-field-next)
 +
 +      (when (not (eq (srecode-overlaid-at-point 'srecode-field)
 +		     (nth 1 fields)))
 +	(error "Region Test: Field %s not under point"
 +	       (object-name (nth 1 fields))))
 +
 +      (srecode-field-prev)
 +
 +      (when (not (eq (srecode-overlaid-at-point 'srecode-field)
 +		     (nth 0 fields)))
 +	(error "Region Test: Field %s not under point"
 +	       (object-name (nth 0 fields))))
 +
 +      ;; Move cursor out of the region and have everything cleaned up.
 +      (goto-char 42)
 +      (srecode-field-post-command)
 +      (when (srecode-active-template-region)
 +	(error "Region Test: Active region did not clear on move out"))
 +
 +      (mapc (lambda (T)
 +	      (when (slot-boundp T 'overlay)
 +		(error "Overlay did not clear off of field %s"
 +		       (object-name T))))
 +	    fields)
 +
 +      ;; End of LET
 +      )
 +
 +    ;; Test variable linkage.
 +    (let* ((srecode-field-archive nil)
 +	   (f1 (srecode-field "Test1" :name "TEST" :start 6 :end 8))
 +	   (f2 (srecode-field "Test2" :name "TEST" :start 28 :end 30))
 +	   (f3 (srecode-field "Test3" :name "NOTTEST" :start 35 :end 40))
 +	   (reg (srecode-template-inserted-region "REG" :start 4 :end 40))
 +	   )
 +      (srecode-overlaid-activate reg)
 +
 +      (when (not (string= (srecode-overlaid-text f1)
 +			  (srecode-overlaid-text f2)))
 +	(error "Linkage Test: Init strings are not ="))
 +      (when (string= (srecode-overlaid-text f1)
 +		     (srecode-overlaid-text f3))
 +	(error "Linkage Test: Init string on dissimilar fields is now the same"))
 +
 +      (goto-char 7)
 +      (insert "a")
 +
 +      (when (not (string= (srecode-overlaid-text f1)
 +			  (srecode-overlaid-text f2)))
 +	(error "Linkage Test: mid-insert strings are not ="))
 +      (when (string= (srecode-overlaid-text f1)
 +		     (srecode-overlaid-text f3))
 +	(error "Linkage Test: mid-insert string on dissimilar fields is now the same"))
 +
 +      (goto-char 9)
 +      (insert "t")
 +
 +      (when (not (string= (srecode-overlaid-text f1) "iast"))
 +	(error "Linkage Test: tail-insert failed to captured added char"))
 +      (when (not (string= (srecode-overlaid-text f1)
 +			  (srecode-overlaid-text f2)))
 +	(error "Linkage Test: tail-insert strings are not ="))
 +      (when (string= (srecode-overlaid-text f1)
 +		     (srecode-overlaid-text f3))
 +	(error "Linkage Test: tail-insert string on dissimilar fields is now the same"))
 +
 +      (goto-char 6)
 +      (insert "b")
 +
 +      (when (not (string= (srecode-overlaid-text f1) "biast"))
 +	(error "Linkage Test: tail-insert failed to captured added char"))
 +      (when (not (string= (srecode-overlaid-text f1)
 +			  (srecode-overlaid-text f2)))
 +	(error "Linkage Test: tail-insert strings are not ="))
 +      (when (string= (srecode-overlaid-text f1)
 +		     (srecode-overlaid-text f3))
 +	(error "Linkage Test: tail-insert string on dissimilar fields is now the same"))
 +
 +      ;; Cleanup
 +      (srecode-delete reg)
 +      )
 +
 +    (set-buffer-modified-p nil)
 +
 +    (message "   All field tests passed.")
 +    ))
 +
 +;;; From srecode-document:
 +
 +(require 'srecode/doc)
 +
 +(defun srecode-document-function-comment-extract-test ()
 +  "Test old comment extraction.
 +Dump out the extracted dictionary."
 +  (interactive)
 +
 +  (srecode-load-tables-for-mode major-mode)
 +  (srecode-load-tables-for-mode major-mode 'document)
 +
 +  (if (not (srecode-table))
 +      (error "No template table found for mode %s" major-mode))
 +
 +  (let* ((temp (srecode-template-get-table (srecode-table)
 +					   "function-comment"
 +					   "declaration"
 +					   'document))
 +	 (fcn-in (semantic-current-tag)))
 +
 +    (if (not temp)
 +	(error "No templates for function comments"))
 +
 +    ;; Try to figure out the tag we want to use.
 +    (when (or (not fcn-in)
 +	      (not (semantic-tag-of-class-p fcn-in 'function)))
 +      (error "No tag of class 'function to insert comment for"))
 +
 +    (let ((lextok (semantic-documentation-comment-preceding-tag fcn-in 'lex))
 +	  )
 +
 +      (when (not lextok)
 +	(error "No comment to attempt an extraction"))
 +
 +      (let ((s (semantic-lex-token-start lextok))
 +	    (e (semantic-lex-token-end lextok))
 +	    (extract nil))
 +
 +	(pulse-momentary-highlight-region s e)
 +
 +	;; Extract text from the existing comment.
 +	(setq extract (srecode-extract temp s e))
 +
 +	(with-output-to-temp-buffer "*SRECODE DUMP*"
 +	  (princ "EXTRACTED DICTIONARY FOR ")
 +	  (princ (semantic-tag-name fcn-in))
 +	  (princ "\n--------------------------------------------\n")
 +	  (srecode-dump extract))))))
 +
 +;;; srecode-tests.el ends here
diff --cc test/manual/cedet/tests/test.c
index 0aa8852b8a9,00000000000..a46486927a7
mode 100644,000000..100644
--- a/test/manual/cedet/tests/test.c
+++ b/test/manual/cedet/tests/test.c
@@@ -1,242 -1,0 +1,242 @@@
 +/* test.c --- Semantic unit test for C.
 +
-    Copyright (C) 2001-2016 Free Software Foundation, Inc.
++   Copyright (C) 2001-2017 Free Software Foundation, Inc.
 +
 +   Author: Eric M. Ludlam 
 +
 +   This file is part of GNU Emacs.
 +
 +   GNU Emacs is free software: you can redistribute it and/or modify
 +   it under the terms of the GNU General Public License as published by
 +   the Free Software Foundation, either version 3 of the License, or
 +   (at your option) any later version.
 +
 +   GNU Emacs is distributed in the hope that it will be useful,
 +   but WITHOUT ANY WARRANTY; without even the implied warranty of
 +   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +   GNU General Public License for more details.
 +
 +   You should have received a copy of the GNU General Public License
 +   along with GNU Emacs.  If not, see .
 +*/
 +
 +/* Attempt to include as many aspects of the C language as possible.
 + */
 +
 +/* types of include files */
 +#include "includeme1.h"
 +#include 
 +#include 
 +#include 
 +#include 
 +#include 
 +
 +#if 0
 +int dont_show_function()
 +{
 +}
 +#endif
 +
 +/* Global types */
 +struct mystruct1 {
 +  int slot11;
 +  char slot12;
 +  float slot13;
 +};
 +
 +struct mystruct2 {
 +  int slot21;
 +  char slot22;
 +  float slot23;
 +} var_of_type_mystruct2;
 +
 +struct {
 +  int slot31;
 +  char slot32;
 +  float slot33;
 +} var_of_anonymous_struct;  
 +
 +typedef struct mystruct1 typedef_of_mystruct1;
 +typedef struct mystruct1 *typedef_of_pointer_mystruct1;
 +typedef struct { int slot_a; } typedef_of_anonymous_struct;
 +typedef struct A {
 +} B;
 +
 +typedef struct mystruct1 td1, td2;
 +
 +union myunion1 {
 +  int slot41;
 +  char slot42;
 +  float slot43;
 +};
 +
 +union myunion2 {
 +  int slot51;
 +  char slot52;
 +  float slot53;
 +} var_of_type_myunion2;
 +
 +struct {
 +  int slot61;
 +  char slot72;
 +  float slot83;
 +} var_of_anonymous_union;  
 +
 +typedef union myunion1 typedef_of_myunion1;
 +typedef union myunion1 *typedef_of_pointer_myunion1;
 +typedef union { int slot_a; } typedef_of_anonymous_union;
 +
 +enum myenum1 { enum11 = 1, enum12 };
 +enum myenum2 { enum21, enum22 = 2 } var_of_type_myenum2;
 +enum { enum31, enum32 } var_of_anonymous_enum;
 +
 +typedef enum myenum1 typedef_of_myenum1;
 +typedef enum myenum1 *typedef_of_pointer_myenum1;
 +typedef enum { enum_a = 3, enum_b } typedef_of_anonymous_enum;
 +
 +typedef int typedef_of_int;
 +
 +/* Here are some simpler variable types */
 +int var1;
 +int varbit1:1;
 +char var2;
 +float var3;
 +mystruct1 var3;
 +struct mystruct1 var4;
 +union myunion1 var5;
 +enum myenum1 var6;
 +
 +char *varp1;
 +char **varp2;
 +char varv1[1];
 +char varv2[1][2];
 +
 +char *varpa1 = "moose";
 +struct mystruct2 vara2 = { 1, 'a', 0.0 };
 +enum myenum1 vara3 = enum11;
 +int vara4 = (int)0.0;
 +int vara5 = funcall();
 +
 +int mvar1, mvar2, mvar3;
 +char *mvarp1, *mvarp2, *mvarp3;
 +char *mvarpa1 = 'a', *mvarpa2 = 'b', *mvarpa3 = 'c';
 +char mvaras1[10], mvaras2[12][13], *mvaras3 = 'd';
 +
 +static register const unsigned int tmvar1;
 +
 +#define MACRO1 1
 +#define MACRO2(foo) (1+foo)
 +
 +/* Here are some function prototypes */
 +
 +/* This is legal, but I decided not to support inferred integer
 + * types on functions and variables.
 + */
 +fun0();
 +int funp1();
 +char funp2(int arg11);
 +float funp3(char arg21, char arg22);
 +struct mystrct1 funp4(struct mystruct2 arg31, union myunion2 arg32);
 +enum myenum1 funp5(char *arg41, union myunion1 *arg42);
 +
 +char funpp1 __P(char argp1, struct mystruct2 argp2, char *arg4p);
 +
 +int fun1();
 +
 +/* Here is a function pointer */
 +int (*funcptr)(int a, int b);
 +
 +/* Function Definitions */
 +
 +/* This is legal, but I decided not to support inferred integer
 + * types on functions and variables.
 + */
 +fun0()
 +{
 +  int sv = 0;
 +}
 +
 +int fun1 ()
 +{
 +  int sv = 1;
 +}
 +
 +int fun1p1 (void)
 +{
 +  int sv = 1;
 +}
 +
 +char fun2(int arg_11)
 +{
 +  char sv = 2;
 +}
 +
 +float fun3(char arg_21, char arg_22)
 +{
 +  char sv = 3;
 +}
 +
 +struct mystrct1 fun4(struct mystruct2 arg31, union myunion2 arg32)
 +{
 +  sv = 4;
 +}
 +
 +enum myenum1 fun5(char *arg41, union myunion1 *arg42)
 +{
 +  sv = 5;
 +}
 +
 +/* Functions with K&R syntax. */
 +struct mystrct1 funk1(arg_31, arg_32)
 +     struct mystruct2 arg_31;
 +     union myunion2 arg32;
 +{
 +  sv = 4;
 +}
 +
 +enum myenum1 *funk2(arg_41, arg_42)
 +     char *arg_41;
 +     union myunion1 *arg_42;
 +{
 +  sv = 5;
 +
 +  if(foo) {
 +  }
 +}
 +
 +int funk3(arg_51, arg_53)
 +     int arg_51;
 +     char arg_53;
 +{
 +  char q = 'a';
 +  int sv = 6;
 +  td1 ms1;
 +  enum myenum1 testconst;
 +
 +  /* Function argument analysis */
 +  funk3(ms1.slot11, arg_53 );
 +  sv = 7;
 +
 +  /* Slot deref on assignee */
 +  ms1.slot11 = s;
 +
 +  /* Enum/const completion */
 +  testconst = e;
 +
 +  /* Bad var/slot and param */
 +  blah.notafunction(moose);
 +
 +  /* Print something. */
 +  printf("Moose", );
 +
 +  tan();
 +}
 +
 +int funk4_fixme(arg_61, arg_62)
 +     int arg_61, arg_62;
 +{
 +  
 +}
 +
 +/* End of C tests */
 +
diff --cc test/manual/cedet/tests/test.el
index 15517da0dc2,00000000000..a0efd40acce
mode 100644,000000..100644
--- a/test/manual/cedet/tests/test.el
+++ b/test/manual/cedet/tests/test.el
@@@ -1,158 -1,0 +1,158 @@@
 +;;; test.el --- Unit test file for Semantic Emacs Lisp support.
 +
- ;; Copyright (C) 2005-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2005-2017 Free Software Foundation, Inc.
 +
 +;; Author: Eric M. Ludlam 
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see .
 +
 +;;; Require
 +;;
 +(require 'semantic)
 +(require 'eieio "../eieio")
 +
 +;; tags encapsulated in eval-when-compile and eval-and-compile
 +;; should be expanded out into the outer environment.
 +(eval-when-compile
 +  (require 'semantic-imenu)
 +  )
 +
 +(eval-and-compile
 +  (defconst const-1 nil)
 +  (defun function-1 (arg)
 +    nil)
 +  )
 +
 +;;; Functions
 +;;
 +(defun a-defun (arg1 arg2 &optional arg3)
 +  "doc a"
 +  nil)
 +
 +(defun a-defun-interactive (arg1 arg2 &optional arg3)
 +  "doc a that is a command"
 +  (interactive "R")
 +  nil)
 +
 +(defun* a-defun* (arg1 arg2 &optional arg3)
 +  "doc a*"
 +  nil)
 +
 +(defsubst a-defsubst (arg1 arg2 &optional arg3)
 +  "doc a-subst"
 +  nil)
 +
 +(defmacro a-defmacro (arg1 arg2 &optional arg3)
 +  "doc a-macro"
 +  nil)
 +
 +(define-overload a-overload (arg)
 +  "doc a-overload"
 +  nil)
 +
 +;;; Methods
 +;;
 +(defmethod a-method ((obj some-class) &optional arg2)
 +  "Doc String for a method."
 +  (call-next-method))
 +
 +(defgeneric a-generic (arg1 arg2)
 +  "General description of a-generic.")
 +
 +;;; Advice
 +;;
 +(defadvice existing-function-to-advise (around test activate)
 +  "Do something special to this fcn."
 +  (ad-do-it))
 +
 +;;; Variables
 +;;
 +(defvar a-defvar (cons 1 2)
 +  "Variable a")
 +
 +(defvar a-defvar-star (cons 1 2)
 +  "*User visible var a")
 +
 +(defconst a-defconst 'a "var doc const")
 +
 +(defcustom a-defcustom nil
 +  "doc custom"
 +  :group 'a-defgroup
 +  :type 'boolean)
 +
 +(defface a-defface 'bold
 +  "A face that is bold.")
 +
 +(defimage ezimage-page-minus
 +  ((:type xpm :file "page-minus.xpm" :ascent center))
 +  "Image used for open files with stuff in them.")
 +
 +;;; Autoloads
 +;;
 +(autoload (quote a-autoload) "somefile"
 +  "Non-interactive autoload." nil nil)
 +
 +(autoload (quote a-autoload-interactive) "somefile"
 +"Interactive autoload." t nil)
 +
 +
 +(defgroup a-defgroup nil
 +  "Group for `emacs-lisp' regression-test")
 +
 +;;; Classes
 +;;
 +(defclass a-class (a-parent)
 +  ((slot-1)
 +   (slot-2 :initarg :slot-2)
 +   (slot-3 :documentation "Doc about slot3")
 +   (slot-4 :type 'boolean)
 +   )
 +  "Doc String for class.")
 +
 +(defclass a-class-abstract ()
 +  nil
 +  "Doc string for abstract class."
 +  :abstract t)
 +
 +;;; Structures
 +;;
 +(defstruct (test-struct-1 :test 'equal)
 +  (slot-1 :equal 'eq)
 +  slot-2)
 +
 +(defstruct test-struct-2
 +  slot-1
 +  slot-2)
 +
 +;;; Semantic specific macros
 +;;
 +(define-lex a-lexer
 +  "Doc String"
 +  this
 +  that)
 +
 +(define-mode-local-override a-overridden-function
 +  emacs-lisp-mode (tag)
 +  "A function that is overloaded."
 +  nil)
 +
 +(defvar-mode-local emacs-lisp-mode a-mode-local-def
 +  "some value")
 +
 +
 +;;; Provide
 +;;
 +(provide 'test)
diff --cc test/manual/cedet/tests/test.make
index 1eb71f7ccc8,00000000000..46421da54d6
mode 100644,000000..100644
--- a/test/manual/cedet/tests/test.make
+++ b/test/manual/cedet/tests/test.make
@@@ -1,79 -1,0 +1,79 @@@
 +# test.make --- Semantic unit test for Make -*- makefile -*-
 +
- # Copyright (C) 2001-2002, 2010-2016 Free Software Foundation, Inc.
++# Copyright (C) 2001-2002, 2010-2017 Free Software Foundation, Inc.
 +
 +# Author: Eric M. Ludlam 
 +
 +# This file is part of GNU Emacs.
 +
 +# GNU Emacs is free software: you can redistribute it and/or modify
 +# it under the terms of the GNU General Public License as published by
 +# the Free Software Foundation, either version 3 of the License, or
 +# (at your option) any later version.
 +
 +# GNU Emacs is distributed in the hope that it will be useful,
 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +# GNU General Public License for more details.
 +
 +# You should have received a copy of the GNU General Public License
 +# along with GNU Emacs.  If not, see .
 +
 +top=
 +ede_FILES=Project.ede Makefile
 +
 +example_MISC=semantic-skel.el skeleton.bnf
 +init_LISP=semantic-load.el
 +DISTDIR=$(top)semantic-$(VERSION)
 +
 +# really goofy & variables tabs
 +A=      B
 +A       =B
 +A=B     C
 +A=B\
 +        C
 +
 +A=	http://${B} \
 +	ftp://${B}
 +B=	test
 +
 +all: example semantic Languages tools senator semantic.info
 +
 +test ${B}: foo bar
 +	@echo ${A}
 +
 +example: 
 +	@
 +
 +init: $(init_LISP)
 +	@echo "(add-to-list 'load-path nil)" > $@-compile-script
 +	@if test ! -z "${LOADPATH}" ; then\
 +	   for loadpath in ${LOADPATH}; do \
 +	      echo "(add-to-list 'load-path \"$$loadpath\")" >> $@-compile-script; \
 +	    done;\
 +	fi
 +	@echo "(setq debug-on-error t)" >> $@-compile-script
 +	$(EMACS) -batch -l $@-compile-script -f batch-byte-compile $^
 +
 +include tesset.mk tusset.mk
 +include oneset.mk
 +
 +ifdef SOME_SYMBOL
 +  VAR1 = foo
 +else
 +  VAR1 = bar
 +endif
 +
 +ifndef SOME_OTHER_SYMBOL
 +  VAR1 = baz
 +endif
 +
 +ifeq ($(VAR1), foo)
 +  VAR2 = gleep
 +else
 +  ifneq ($(VAR1), foo)
 +    VAR2 = glop
 +  endif
 +endif
 +
 +# End of Makefile
diff --cc test/manual/cedet/tests/testdoublens.cpp
index 63c4deedd08,00000000000..e9a6ba52673
mode 100644,000000..100644
--- a/test/manual/cedet/tests/testdoublens.cpp
+++ b/test/manual/cedet/tests/testdoublens.cpp
@@@ -1,166 -1,0 +1,166 @@@
 +// testdoublens.cpp --- semantic-ia-utest completion engine unit tests
 +
- // Copyright (C) 2008-2016 Free Software Foundation, Inc.
++// Copyright (C) 2008-2017 Free Software Foundation, Inc.
 +
 +// Author: Eric M. Ludlam 
 +
 +// This file is part of GNU Emacs.
 +
 +// GNU Emacs is free software: you can redistribute it and/or modify
 +// it under the terms of the GNU General Public License as published by
 +// the Free Software Foundation, either version 3 of the License, or
 +// (at your option) any later version.
 +
 +// GNU Emacs is distributed in the hope that it will be useful,
 +// but WITHOUT ANY WARRANTY; without even the implied warranty of
 +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +// GNU General Public License for more details.
 +
 +// You should have received a copy of the GNU General Public License
 +// along with GNU Emacs.  If not, see .
 +
 +#include "testdoublens.hpp"
 +
 +namespace Name1 {
 +  namespace Name2 {
 +
 +    Foo::Foo()
 +    {
 +      p// -1-
 +	// #1# ( "pMumble" "publishStuff" )
 +	;
 +    }
 +
 +    int Foo::get() // ^1^
 +    {
 +      p// -2-
 +	// #2# ( "pMumble" "publishStuff" )
 +	;
 +      return 0;
 +    }
 +
 +    void Foo::publishStuff(int /* a */, int /* b */) // ^2^
 +    {
 +    }
 +
 +    void Foo::sendStuff(int /* a */, int /* b */) // ^3^
 +    {
 +    }
 +
 +  } // namespace Name2
 +} // namespace Name1
 +
 +// Test multiple levels of metatype expansion
 +int test_fcn () {
 +  stage3_Foo MyFoo;
 +
 +  MyFoo.// -3-
 +    // #3# ( "Mumble" "get" )
 +    ;
 +
 +  Name1::Name2::F//-4-
 +    // #4# ( "Foo" )
 +    ;
 +
 +  // @TODO - get this working...
 +  Name1::stage2_Foo::M//-5-
 +    /// #5# ( "Mumble" )
 +    ;
 +}
 +
 +stage3_Foo foo_fcn() {
 +  // Can we go "up" to foo with senator-go-to-up-reference?
 +}
 +
 +
 +// Second test from Ravikiran Rajagopal
 +
 +namespace A {
 +  class foo {
 +  public:
 +    void aa();
 +    void bb();
 +  };
 +}
 +namespace A {
 +  class bar {
 +  public:
 +    void xx();
 +  public:
 +    foo myFoo;
 +  };
 +
 +  void bar::xx()
 +  {
 +    myFoo.// -6- <--- cursor is here after the dot
 +      // #6# ( "aa" "bb" )
 +      ;
 +  }
 +}
 +
 +// Double namespace example from Hannu Koivisto
 +//
 +// This is tricky because the parent class "Foo" is found within the
 +// scope of B, so the scope calculation needs to put that together
 +// before searching for parents in scope.
 +namespace a {
 +  namespace b {
 +
 +    class Bar : public Foo
 +    {
 +      int baz();
 +    };
 +
 +    int Bar::baz()
 +    {
 +      return dum// -7-
 +	// #7# ( "dumdum" )
 +	;
 +    }
 +
 +  } // namespace b
 +} // namespace a
 +
 +// Three namespace example from Hannu Koivisto
 +//
 +// This one is special in that the name e::Foo, where "e" is in
 +// the scope, and not referenced from the global namespace.  This
 +// wasn't previously handled, so the fullscope needed to be added
 +// to the list of things searched when in split-name decent search mode
 +// for scopes.
 +
 +namespace d {
 +  namespace e {
 +
 +    class Foo
 +    {
 +    public:
 +      int write();
 +    };
 +
 +  } // namespace d
 +} // namespace e
 +
 +
 +namespace d {
 +  namespace f {
 +
 +    class Bar
 +    {
 +    public:
 +      int baz();
 +
 +    private:
 +      e::Foo &foo;
 +    };
 +
 +    int Bar::baz()
 +    {
 +      return foo.w// -8-
 +	// #8# ( "write" )
 +	;
 +    }
 +
 +  } // namespace f
 +} // namespace d
 +
diff --cc test/manual/cedet/tests/testdoublens.hpp
index 6d2a0f0755e,00000000000..556f068d586
mode 100644,000000..100644
--- a/test/manual/cedet/tests/testdoublens.hpp
+++ b/test/manual/cedet/tests/testdoublens.hpp
@@@ -1,70 -1,0 +1,70 @@@
 +// testdoublens.hpp --- Header file used in one of the Semantic tests
 +
- // Copyright (C) 2008-2016 Free Software Foundation, Inc.
++// Copyright (C) 2008-2017 Free Software Foundation, Inc.
 +
 +// Author: Eric M. Ludlam 
 +
 +// This file is part of GNU Emacs.
 +
 +// GNU Emacs is free software: you can redistribute it and/or modify
 +// it under the terms of the GNU General Public License as published by
 +// the Free Software Foundation, either version 3 of the License, or
 +// (at your option) any later version.
 +
 +// GNU Emacs is distributed in the hope that it will be useful,
 +// but WITHOUT ANY WARRANTY; without even the implied warranty of
 +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +// GNU General Public License for more details.
 +
 +// You should have received a copy of the GNU General Public License
 +// along with GNU Emacs.  If not, see .
 +
 +namespace Name1 {
 +  namespace Name2 {
 +
 +    class Foo
 +    {
 +      typedef unsigned int Mumble;
 +    public:
 +      Foo();
 +      ~Foo();
 +      int get();
 +
 +    private:
 +      void publishStuff(int a, int b);
 +
 +      void sendStuff(int a, int b);
 +    
 +      Mumble* pMumble;
 +    };
 +
 +    typedef Foo stage1_Foo;
 +
 +  } // namespace Name2
 +
 +  typedef Name2::stage1_Foo stage2_Foo;
 +
 +  typedef Name2::Foo decl_stage1_Foo;
 +
 +} // namespace Name1
 +
 +typedef Name1::stage2_Foo stage3_Foo;
 +
 +
 +// Double namespace from Hannu Koivisto
 +namespace a {
 +  namespace b {
 +
 +    class Foo
 +    {
 +      struct Dum {
 +        int diDum;
 +      };
 +
 +    protected:
 +      mutable a::b::Foo::Dum dumdum;
 +    };
 +
 +  } // namespace b
 +} // namespace a
 +
diff --cc test/manual/cedet/tests/testjavacomp.java
index f0abfc97b06,00000000000..c32a17ca248
mode 100644,000000..100644
--- a/test/manual/cedet/tests/testjavacomp.java
+++ b/test/manual/cedet/tests/testjavacomp.java
@@@ -1,67 -1,0 +1,67 @@@
 +//  testjavacomp.java --- Semantic unit test for Java
 +
- // Copyright (C) 2009-2016 Free Software Foundation, Inc.
++// Copyright (C) 2009-2017 Free Software Foundation, Inc.
 +
 +//  Author: Eric M. Ludlam 
 +
 +//  This file is part of GNU Emacs.
 +
 +//  GNU Emacs is free software: you can redistribute it and/or modify
 +//  it under the terms of the GNU General Public License as published by
 +//  the Free Software Foundation, either version 3 of the License, or
 +//  (at your option) any later version.
 +
 +//  GNU Emacs is distributed in the hope that it will be useful,
 +//  but WITHOUT ANY WARRANTY; without even the implied warranty of
 +//  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +//  GNU General Public License for more details.
 +
 +//  You should have received a copy of the GNU General Public License
 +//  along with GNU Emacs.  If not, see .
 +
 +package tests.testjavacomp;
 +
 +class secondClass {
 +    private void scFuncOne() {    }
 +    public void scFuncOne() {    }
 +}
 +
 +
 +public class testjavacomp {
 +
 +    private int funcOne() {    }
 +    private int funcTwo() {    }
 +    private char funcThree() {    }
 +
 +    class nestedClass {
 +	private void ncFuncOne() {	}
 +	public void ncFuncOne() {	}
 +    }
 +
 +    public void publicFunc() {
 +
 +	int i;
 +
 +	i = fu// -1-
 +	    // #1# ( "funcOne" "funcTwo" )
 +	    ;
 +
 +	fu// -2-
 +	    // #2# ( "funcOne" "funcThree" "funcTwo" )
 +	    ;
 +
 +	secondClass SC;
 +
 +	SC.//-3-
 +	    // #3# ( "scFuncOne" )
 +	    ;
 +
 +	nestedClass NC;
 +
 +	// @todo - need to fix this?  I don't know if  this is legal java.
 +	NC.// - 4-
 +	    // #4# ( "ncFuncOne" )
 +	    ;
 +    }
 +
 +} // testjavacomp
diff --cc test/manual/cedet/tests/testpolymorph.cpp
index 94ae9d90413,00000000000..27aa08b155b
mode 100644,000000..100644
--- a/test/manual/cedet/tests/testpolymorph.cpp
+++ b/test/manual/cedet/tests/testpolymorph.cpp
@@@ -1,130 -1,0 +1,130 @@@
 +/** testpolymorph.cpp --- A sequence of polymorphism examples.
 + *
-  * Copyright (C) 2009-2016 Free Software Foundation, Inc.
++ * Copyright (C) 2009-2017 Free Software Foundation, Inc.
 + *
 + * Author: Eric M. Ludlam 
 + *
 + * This file is part of GNU Emacs.
 + *
 + * GNU Emacs is free software: you can redistribute it and/or modify
 + * it under the terms of the GNU General Public License as published by
 + * the Free Software Foundation, either version 3 of the License, or
 + * (at your option) any later version.
 + *
 + * GNU Emacs is distributed in the hope that it will be useful,
 + * but WITHOUT ANY WARRANTY; without even the implied warranty of
 + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 + * GNU General Public License for more details.
 + *
 + * You should have received a copy of the GNU General Public License
 + * along with GNU Emacs.  If not, see .
 + */
 +
 +#include 
 +
 +// Test 1 - Functions w/ prototypes
 +namespace proto {
 +
 +  int pt_func1(int arg1);
 +  int pt_func1(int arg1) {
 +    return 0;
 +  }
 +
 +}
 +
 +// Test 2 - Functions w/ different arg lists.
 +namespace fcn_poly {
 +
 +  int pm_func(void) {
 +    return 0;
 +  }
 +  int pm_func(int a) {
 +    return a;
 +  }
 +  int pm_func(char a) {
 +    return int(a);
 +  }
 +  int pm_func(double a) {
 +    return int(floor(a));
 +  }
 +
 +}
 +
 +// Test 3 - Methods w/ different arg lists.
 +class meth_poly {
 +public:
 +  int pm_meth(void) {
 +    return 0;
 +  }
 +  int pm_meth(int a) {
 +    return a;
 +  }
 +  int pm_meth(char a) {
 +    return int(a);
 +  }
 +  int pm_meth(double a) {
 +    return int(floor(a));
 +  }
 +
 +};
 +
 +// Test 4 - Templates w/ partial specifiers.
 +namespace template_partial_spec {
 +  template  class test
 +  {
 +  public:
 +    void doSomething(T t) { };
 +  };
 +
 +  template  class test
 +  {
 +  public:
 +    void doSomething(T* t) { };
 +  };
 +}
 +
 +// Test 5 - Templates w/ full specialization which may or may not share
 +// common functions.
 +namespace template_full_spec {
 +  template  class test
 +  {
 +  public:
 +    void doSomething(T t) { };
 +    void doSomethingElse(T t) { };
 +  };
 +
 +  template <> class test
 +  {
 +  public:
 +    void doSomethingElse(int t) { };
 +    void doSomethingCompletelyDifferent(int t) { };
 +  };
 +}
 +
 +// Test 6 - Dto., but for templates with multiple parameters.
 +namespace template_multiple_spec {
 +  template  class test
 +  {
 +  public:
 +    void doSomething(T1 t) { };
 +    void doSomethingElse(T2 t) { };
 +  };
 +
 +  template  class test
 +  {
 +  public:
 +    void doSomething(int t) { };
 +    void doSomethingElse(T2 t) { };
 +  };
 +
 +  template <> class test
 +  {
 +  public:
 +    void doSomething(float t) { };
 +    void doSomethingElse(int t) { };
 +    void doNothing(void) { };
 +  };
 +}
 +
 +
 +// End of polymorphism test file.
diff --cc test/manual/cedet/tests/testspp.c
index cfb3996db47,00000000000..02eab53afb6
mode 100644,000000..100644
--- a/test/manual/cedet/tests/testspp.c
+++ b/test/manual/cedet/tests/testspp.c
@@@ -1,102 -1,0 +1,102 @@@
 +/* testspp.cpp --- Semantic unit test for the C preprocessor
 +
-    Copyright (C) 2007-2016 Free Software Foundation, Inc.
++   Copyright (C) 2007-2017 Free Software Foundation, Inc.
 +
 +   Author: Eric M. Ludlam 
 +
 +   This file is part of GNU Emacs.
 +
 +   GNU Emacs is free software: you can redistribute it and/or modify
 +   it under the terms of the GNU General Public License as published by
 +   the Free Software Foundation, either version 3 of the License, or
 +   (at your option) any later version.
 +
 +   GNU Emacs is distributed in the hope that it will be useful,
 +   but WITHOUT ANY WARRANTY; without even the implied warranty of
 +   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +   GNU General Public License for more details.
 +
 +   You should have received a copy of the GNU General Public License
 +   along with GNU Emacs.  If not, see .
 +*/
 +
 +int some_fcn (){}
 +
 +
 +#ifndef MOOSE
 +int pre_show_moose(){}
 +#endif
 +
 +#ifdef MOOSE
 +int pre_dont_show_moose(){}
 +#endif
 +
 +#if !defined(MOOSE)
 +int pre_show_moose_if(){}
 +#endif
 +
 +#if defined(MOOSE)
 +int pre_dont_show_moose_if(){}
 +#endif
 +
 +#define MOOSE
 +
 +#if 0
 +int dont_show_function_if_0(){}
 +#endif
 +
 +#if 1
 +int show_function_if_1(){}
 +#endif
 +
 +#ifdef MOOSE
 +int moose_function(){}
 +#endif
 +
 +#ifndef MOOSE
 +int dont_show_moose(){}
 +#endif
 +
 +#if defined(MOOSE)
 +int moose_function_if(){}
 +#endif
 +
 +#if !defined(MOOSE)
 +int dont_show_moose_if() {}
 +#endif
 +
 +#undef MOOSE
 +
 +#ifdef MOOSE
 +int no_handy_moose(){}
 +#endif
 +
 +#ifndef MOOSE
 +int show_moose_else() {}
 +#else
 +int no_show_moose_else(){}
 +#endif
 +
 +
 +#ifdef MOOSE
 +int no_show_moose_else_2() {}
 +#else
 +int show_moose_else_2() {}
 +#endif
 +
 +#if defined(MOOSE)
 +int no_show_moose_elif() {}
 +#elif !defined(MOOSE)
 +int show_moose_elif() {}
 +#else
 +int no_show_moose_elif_else() {}
 +#endif
 +
 +#if defined(MOOSE)
 +int no_show_moose_if_elif_2() {}
 +#elif defined(COW)
 +int no_show_moose_elif_2() {}
 +#else
 +int show_moose_elif_else() {}
 +#endif
 +
diff --cc test/manual/cedet/tests/testsppreplace.c
index fbbaa75fee1,00000000000..56ef320f752
mode 100644,000000..100644
--- a/test/manual/cedet/tests/testsppreplace.c
+++ b/test/manual/cedet/tests/testsppreplace.c
@@@ -1,154 -1,0 +1,154 @@@
 +/* testsppreplace.c --- unit test for CPP/SPP Replacement
-    Copyright (C) 2007-2016 Free Software Foundation, Inc.
++   Copyright (C) 2007-2017 Free Software Foundation, Inc.
 +
 +   Author: Eric M. Ludlam 
 +
 +   This file is part of GNU Emacs.
 +
 +   GNU Emacs is free software: you can redistribute it and/or modify
 +   it under the terms of the GNU General Public License as published by
 +   the Free Software Foundation, either version 3 of the License, or
 +   (at your option) any later version.
 +
 +   GNU Emacs is distributed in the hope that it will be useful,
 +   but WITHOUT ANY WARRANTY; without even the implied warranty of
 +   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +   GNU General Public License for more details.
 +
 +   You should have received a copy of the GNU General Public License
 +   along with GNU Emacs.  If not, see .
 +*/
 +
 +/* TEST: The EMU keyword doesn't screw up the function defn. */
 +#define EMU
 +#define EMU2 /*comment*/
 +char EMU parse_around_emu EMU2 (EMU)
 +{
 +}
 +
 +/* TEST: A simple word can be replaced in a definition. */
 +#define SUBFLOAT /* Some Float */ float
 +SUBFLOAT returnanfloat()
 +{
 +}
 +
 +/* TEST: Punctuation an be replaced in a definition. */
 +#define COLON :
 +int foo COLON COLON bar ()
 +{
 +}
 +
 +/* TEST: Multiple lexical characters in a definition */
 +#define SUPER mysuper::
 +int SUPER baz ()
 +{
 +}
 +
 +/* TEST: Macro replacement. */
 +#define INT_FCN(name) int name (int in)
 +
 +INT_FCN(increment) {
 +  return in+1;
 +}
 +
 +/* TEST: Macro replacement with complex args */
 +#define P_(proto) ()
 +
 +int myFcn1 P_((a,b));
 +
 +#define P__(proto) proto
 +
 +int myFcn2 P__((int a, int b));
 +int myFcn3 (int a, int b);
 +
 +/* TEST: Multiple args to a macro. */
 +#define MULTI_ARGS(name, field1, field2, field3) struct name { int field1; int field2; int field3; }
 +
 +MULTI_ARGS(ma_struct, moose, penguin, emu);
 +
 +/* TEST: Macro w/ args, but no body. */
 +#define NO_BODY(name)
 +
 +NO_BODY(Moose);
 +
 +/* TEST: Not a macro with args, but close. */
 +#define NOT_WITH_ARGS     (moose)
 +
 +int not_with_args_fcn NOT_WITH_ARGS
 +{
 +}
 +
 +/* TEST: macro w/ continuation. */
 +#define WITH_CONT \
 +  continuation_symbol
 +
 +int WITH_CONT () { };
 +
 +/* TEST: macros in a macro - tail processing */
 +#define tail_with_args_and_long_name(a) (int a)
 +#define int_arg tail_with_args_and_long_name
 +
 +int tail int_arg(q) {}
 +
 +/* TEST: macros used improperly. */
 +#define tail_fail tail_with_args_and_long_name(q)
 +
 +int tail_fcn tail_fail(q);
 +
 +/* TEST: feature of CPP from LSD  */
 +#define __gthrw_(name) __gthrw_ ## name
 +
 +int __gthrw_(foo) (int arg1) { }
 +
 +/* TEST: macros using macros */
 +#define macro_foo foo
 +#define mf_declare int macro_foo
 +
 +mf_declare;
 +
 +/* TEST: macros with args using macros */
 +#define Amacro(A) (int A)
 +#define mf_Amacro(B) int B Amacro(B)
 +
 +mf_Amacro(noodle);
 +
 +/* TEST: Double macro using the argument stack. */
 +#define MACRO0(name) int that_ ## name(int i);
 +#define MACRO1(name) int this_ ## name(int i);
 +#define MACRO2(name) MACRO0(name) MACRO1(name)
 +
 +MACRO2(foo)
 +
 +/* TEST: The G++ namespace macro hack.  Not really part of SPP. */
 +_GLIBCXX_BEGIN_NAMESPACE(baz)
 +
 +  int bazfnc(int b) { }
 +
 +_GLIBCXX_END_NAMESPACE;
 +
 +_GLIBCXX_BEGIN_NESTED_NAMESPACE(foo,bar)
 +
 +  int foo_bar_func(int a) { }
 +
 +_GLIBCXX_END_NESTED_NAMESPACE;
 +
 +
 +/* TEST: The VC++ macro hack. */
 +_STD_BEGIN
 +
 +  int inside_std_namespace(int a) { }
 +
 +_STD_END
 +
 +/* TEST: Recursion prevention.  CPP doesn't allow even 1 level of recursion. */
 +#define STARTMACRO MACROA
 +#define MACROA MACROB
 +#define MACROB MACROA
 +
 +int STARTMACRO () {
 +
 +}
 +
 +
 +/* END */
 +
diff --cc test/manual/cedet/tests/testsppreplaced.c
index 8cbe05bd4f7,00000000000..3ba90aa4ddb
mode 100644,000000..100644
--- a/test/manual/cedet/tests/testsppreplaced.c
+++ b/test/manual/cedet/tests/testsppreplaced.c
@@@ -1,117 -1,0 +1,117 @@@
 +/* testsppreplaced.c --- unit test for CPP/SPP Replacement
-    Copyright (C) 2007-2016 Free Software Foundation, Inc.
++   Copyright (C) 2007-2017 Free Software Foundation, Inc.
 +
 +   Author: Eric M. Ludlam 
 +
 +   This file is part of GNU Emacs.
 +
 +   GNU Emacs is free software: you can redistribute it and/or modify
 +   it under the terms of the GNU General Public License as published by
 +   the Free Software Foundation, either version 3 of the License, or
 +   (at your option) any later version.
 +
 +   GNU Emacs is distributed in the hope that it will be useful,
 +   but WITHOUT ANY WARRANTY; without even the implied warranty of
 +   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +   GNU General Public License for more details.
 +
 +   You should have received a copy of the GNU General Public License
 +   along with GNU Emacs.  If not, see .
 +*/
 +
 +/* What the SPP replace file would looklike with MACROS replaced: */
 +
 +/* TEST: The EMU keyword doesn't screw up the function defn. */
 +char parse_around_emu ()
 +{
 +}
 +
 +/* TEST: A simple word can be replaced in a definition. */
 +float returnanfloat()
 +{
 +}
 +
 +/* TEST: Punctuation an be replaced in a definition. */
 +int foo::bar ()
 +{
 +}
 +
 +/* TEST: Multiple lexical characters in a definition */
 +int mysuper::baz ()
 +{
 +}
 +
 +/* TEST: Macro replacement. */
 +int increment (int in) {
 +  return in+1;
 +}
 +
 +/* TEST: Macro replacement with complex args */
 +int myFcn1 ();
 +
 +int myFcn2 (int a, int b);
 +int myFcn3 (int a, int b);
 +
 +/* TEST: Multiple args to a macro. */
 +struct ma_struct { int moose; int penguin; int emu; };
 +
 +/* TEST: Macro w/ args, but no body. */
 +
 +/* TEST: Not a macro with args, but close. */
 +int not_with_args_fcn (moose)
 +{
 +}
 +
 +/* TEST: macro w/ continuation. */
 +int continuation_symbol () { };
 +
 +/* TEST: macros in a macro - tail processing */
 +
 +int tail (int q) {}
 +
 +/* TEST: macros used improperly */
 +
 +int tail_fcn(int q);
 +
 +/* TEST: feature of CPP from LSD  */
 +
 +int __gthrw_foo (int arg1) { }
 +
 +/* TEST: macros using macros */
 +int foo;
 +
 +/* TEST: macros with args using macros */
 +int noodle(int noodle);
 +
 +/* TEST: Double macro using the argument stack. */
 +int that_foo(int i);
 +int this_foo(int i);
 +
 +/* TEST: The G++ namespace macro hack.  Not really part of SPP. */
 +namespace baz {
 +
 +  int bazfnc(int b) { }
 +
 +}
 +
 +namespace foo { namespace bar {
 +
 +    int foo_bar_func(int a) { }
 +
 +  }
 +}
 +
 +/* TEST: The VC++ macro hack. */
 +namespace std {
 +
 +  int inside_std_namespace(int a) { }
 +
 +}
 +
 +/* TEST: Recursion prevention.  CPP doesn't allow even 1 level of recursion. */
 +int MACROA () {
 +
 +}
 +
 +
 +/* End */
diff --cc test/manual/cedet/tests/testsubclass.cpp
index 2cb9e763888,00000000000..e74ca43124a
mode 100644,000000..100644
--- a/test/manual/cedet/tests/testsubclass.cpp
+++ b/test/manual/cedet/tests/testsubclass.cpp
@@@ -1,249 -1,0 +1,249 @@@
 +// testsubclass.cpp --- unit test for analyzer and complex C++ inheritance
 +
- // Copyright (C) 2007-2016 Free Software Foundation, Inc.
++// Copyright (C) 2007-2017 Free Software Foundation, Inc.
 +
 +// Author: Eric M. Ludlam 
 +
 +// This file is part of GNU Emacs.
 +
 +// GNU Emacs is free software: you can redistribute it and/or modify
 +// it under the terms of the GNU General Public License as published by
 +// the Free Software Foundation, either version 3 of the License, or
 +// (at your option) any later version.
 +
 +// GNU Emacs is distributed in the hope that it will be useful,
 +// but WITHOUT ANY WARRANTY; without even the implied warranty of
 +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +// GNU General Public License for more details.
 +
 +// You should have received a copy of the GNU General Public License
 +// along with GNU Emacs.  If not, see .
 +
 +//#include 
 +#include "testsubclass.hh"
 +
 +void animal::moose::setFeet(int numfeet) //^1^
 +{
 +  if (numfeet > 4) {
 +    std::cerr << "Why would a moose have more than 4 feet?" << std::endl;
 +    return;
 +  }
 +
 +  fFeet = numfeet;
 +}
 +
 +int animal::moose::getFeet() //^2^
 +{
 +  return fFeet;
 +}
 +
 +void animal::moose::doNothing() //^3^
 +{
 +  animal::moose foo();
 +
 +  fFeet = N// -15-
 +    ; // #15# ( "NAME1" "NAME2" "NAME3" )
 +}
 +
 +
 +void deer::moose::setAntlers(bool have_antlers) //^4^
 +{
 +  fAntlers = have_antlers;
 +}
 +
 +bool deer::moose::getAntlers() //^5^
 +// %1% ( ( "testsubclass.cpp" "testsubclass.hh" ) ( "deer::moose::doSomething" "deer::moose::getAntlers" "moose" ) )
 +{
 +  return fAntlers;
 +}
 +
 +bool i_dont_have_symrefs()
 +// %2% ( ("testsubclass.cpp" ) ("i_dont_have_symrefs"))
 +{
 +}
 +
 +void deer::moose::doSomething() //^6^
 +{
 +  // All these functions should be identified by semantic analyzer.
 +  getAntlers();
 +  setAntlers(true);
 +
 +  getFeet();
 +  setFeet(true);
 +
 +  doNothing();
 +
 +  fSomeField = true;
 +
 +  fIsValid = true;
 +}
 +
 +void deer::alces::setLatin(bool l) {
 +  fLatin = l;
 +}
 +
 +bool deer::alces::getLatin() {
 +  return fLatin;
 +}
 +
 +void deer::alces::doLatinStuff(moose moosein) {
 +  // All these functions should be identified by semantic analyzer.
 +  getFeet();
 +  setFeet(true);
 +
 +  getLatin();
 +  setLatin(true);
 +
 +  doNothing();
 +
 +  deer::moose foo();
 +
 +
 +}
 +
 +moose deer::alces::createMoose()
 +{
 +  moose MooseVariableName;
 +  bool tmp;
 +  int itmp;
 +  bool fool;
 +  int fast;
 +
 +  MooseVariableName = createMoose();
 +
 +  doLatinStuff(MooseVariableName);
 +
 +  tmp = this.f// -1-
 +    // #1# ( "fAlcesBool" "fIsValid" "fLatin" )
 +    ;
 +
 +  itmp = this.f// -2-
 +    // #2# ( "fAlcesInt" "fGreek" "fIsProtectedInt" )
 +    ;
 +
 +  tmp = f// -3-
 +    // #3# ( "fAlcesBool" "fIsValid" "fLatin" "fool" )
 +    ;
 +
 +  itmp = f// -4-
 +    // #4# ( "fAlcesInt" "fGreek" "fIsProtectedInt" "fast" )
 +    ;
 +
 +  MooseVariableName = m// -5-
 +    // #5# ( "moose" )
 +
 +  return MooseVariableName;
 +}
 +
 +/** Test Scope Changes
 + *
 + * This function is rigged to make sure the scope changes to account
 + * for different locations in local variable parsing.
 + */
 +int someFunction(int mPickle)
 +{
 +  moose mMoose = deer::alces::createMoose();
 +
 +  if (mPickle == 1) {
 +
 +    int mOption1 = 2;
 +
 +    m// -5-
 +      // #5# ( "mMoose" "mOption1" "mPickle" )
 +      ;
 +
 +  } else {
 +
 +    int mOption2 = 2;
 +
 +    m// -6-
 +      // #6# ( "mMoose" "mOption2" "mPickle" )
 +      ;
 +  }
 +
 +}
 +
 +// Thanks Ming-Wei Chang for this next example.
 +
 +namespace pub_priv {
 +
 +  class A{
 +  private:
 +    void private_a(){}
 +  public:
 +    void public_a();
 +  };
 +
 +  void A::public_a() {
 +    A other_a;
 +
 +    other_a.p// -7-
 +      // #7# ( "private_a" "public_a" )
 +      ;
 +  }
 +
 +  int some_regular_function(){
 +    A a;
 +    a.p// -8-
 +      // #8# ( "public_a" )
 +      ;
 +    return 0;
 +  }
 +
 +}
 +
 +
 +/** Test Scope w/in a function (non-method) with classes using
 + * different levels of inheritance.
 + */
 +int otherFunction()
 +{
 +  sneaky::antelope Antelope(1);
 +  sneaky::jackalope Jackalope(1);
 +  sneaky::bugalope Bugalope(1);
 +
 +  Antelope.// -9-
 +    // #9# ( "fAntyPublic" "fQuadPublic" "testAccess")
 +    ;
 +
 +  Jackalope.// -10-
 +    // #10# ( "fBunnyPublic" "testAccess")
 +    ;
 +
 +  Jackalope// @1@ 6
 +    ;
 +  Jackalope;
 +  Jackalope;
 +  Jackalope;
 +
 +  Bugalope.// -11-
 +    // #11# ( "fBugPublic" "testAccess")
 +    ;
 +  Bugalope// @2@ 3
 +    ;
 +}
 +
 +/** Test methods within each class for types of access to the baseclass.
 + */
 +
 +bool sneaky::antelope::testAccess() //^7^
 +{
 +  this.// -12-
 +    // #12# ( "fAntyPrivate" "fAntyProtected" "fAntyPublic" "fQuadProtected" "fQuadPublic" "testAccess" )
 +    ;
 +}
 +
 +bool sneaky::jackalope::testAccess() //^8^
 +{
 +  this.// -13-
 +    // #13# ( "fBunnyPrivate" "fBunnyProtected" "fBunnyPublic" "fQuadProtected" "fQuadPublic" "testAccess" )
 +    ;
 +}
 +
 +bool sneaky::bugalope::testAccess() //^9^
 +{
 +  this.// -14-
 +    // #14# ( "fBugPrivate" "fBugProtected" "fBugPublic" "fQuadPublic" "testAccess" )
 +    ;
 +}
 +
diff --cc test/manual/cedet/tests/testsubclass.hh
index 7c93f8ec02d,00000000000..6f199c20bd3
mode 100644,000000..100644
--- a/test/manual/cedet/tests/testsubclass.hh
+++ b/test/manual/cedet/tests/testsubclass.hh
@@@ -1,191 -1,0 +1,191 @@@
 +// testsubclass.hh --- unit test for analyzer and complex C++ inheritance
 +
- // Copyright (C) 2007-2016 Free Software Foundation, Inc.
++// Copyright (C) 2007-2017 Free Software Foundation, Inc.
 +
 +// Author: Eric M. Ludlam 
 +
 +// This file is part of GNU Emacs.
 +
 +// GNU Emacs is free software: you can redistribute it and/or modify
 +// it under the terms of the GNU General Public License as published by
 +// the Free Software Foundation, either version 3 of the License, or
 +// (at your option) any later version.
 +
 +// GNU Emacs is distributed in the hope that it will be useful,
 +// but WITHOUT ANY WARRANTY; without even the implied warranty of
 +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +// GNU General Public License for more details.
 +
 +// You should have received a copy of the GNU General Public License
 +// along with GNU Emacs.  If not, see .
 +
 +//#include 
 +// #include 
 +
 +#ifndef TESTSUBCLASS_HH
 +#define TESTSUBCLASS_HH
 +
 +namespace animal {
 +
 +  class moose {
 +  public:
 +    moose() : fFeet(0),
 +	      fIsValid(false)
 +    { }
 +
 +    virtual void setFeet(int);
 +    int getFeet();
 +
 +    void doNothing();
 +
 +    enum moose_enum {
 +      NAME1, NAME2, NAME3 };
 +      
 +
 +  protected:
 +
 +    bool fIsValid;
 +    int fIsProtectedInt;
 +
 +  private:
 +    int fFeet; // Usually 2 or 4.
 +    bool fIsPrivateBool;
 +    
 +  }; // moose
 +
 +  int two_prototypes();
 +  int two_prototypes();
 +
 +  class quadruped {
 +  public:
 +    quadruped(int a) : fQuadPrivate(a)
 +    { }
 +
 +    int fQuadPublic;
 +
 +  protected:
 +    int fQuadProtected;
 +
 +  private:
 +    int fQuadPrivate;
 +
 +  };
 +
 +}
 +
 +
 +namespace deer {
 +
 +  class moose : public animal::moose {
 +  public:
 +    moose() : fAntlers(false)
 +    { }
 +
 +    void setAntlers(bool);
 +    bool getAntlers();
 +
 +    void doSomething();
 +
 +  protected:
 +
 +    bool fSomeField;
 +
 +  private:
 +    bool fAntlers;
 +
 +  };
 +
 +} // deer
 +
 +// A second namespace of the same name will test the
 +// namespace merging needed to resolve deer::alces
 +namespace deer {
 +
 +  class alces : public animal::moose {
 +  public:
 +    alces(int lat) : fLatin(lat)
 +    { }
 +
 +    void setLatin(bool);
 +    bool getLatin();
 +
 +    void doLatinStuff(moose moosein); // for completion testing
 +
 +    moose createMoose(); // for completion testing.
 +
 +  protected:
 +    bool fAlcesBool;
 +    int fAlcesInt;
 +
 +  private:
 +    bool fLatin;
 +    int fGreek;
 +  };
 +
 +};
 +
 +// A third namespace with classes that does protected and private inheritance.
 +namespace sneaky {
 +
 +  class antelope : public animal::quadruped {
 +
 +  public:
 +    antelope(int a) : animal::quadruped(),
 +		      fAntyProtected(a)
 +    {}
 +
 +    int fAntyPublic;
 +
 +    bool testAccess();
 +
 +  protected:
 +    int fAntyProtected;
 +
 +  private :
 +    int fAntyPrivate;
 +
 +  };
 +
 +  class jackalope : protected animal::quadruped {
 +
 +  public:
 +    jackalope(int a) : animal::quadruped(),
 +		       fBunny(a)
 +    {}
 +
 +    int fBunnyPublic;
 +
 +    bool testAccess();
 +
 +  protected:
 +    bool fBunnyProtected;
 +
 +  private :
 +    bool fBunnyPrivate;
 +
 +  };
 +
 +  // Nothing specified means private.
 +  class bugalope : /* private*/  animal::quadruped {
 +
 +  public:
 +    bugalope(int a) : animal::quadruped(),
 +		       fBug(a)
 +    {}
 +
 +    int fBugPublic;
 +
 +    bool testAccess();
 +  protected:
 +    bool fBugProtected;
 +
 +  private :
 +    bool fBugPrivate;
 +
 +  };
 +
 +
 +};
 +
 +#endif
 +
diff --cc test/manual/cedet/tests/testtypedefs.cpp
index 312a77f0058,00000000000..e6c91f736bf
mode 100644,000000..100644
--- a/test/manual/cedet/tests/testtypedefs.cpp
+++ b/test/manual/cedet/tests/testtypedefs.cpp
@@@ -1,81 -1,0 +1,81 @@@
 +// testtypedefs.cpp --- Sample with some fake bits out of std::string
 +
- // Copyright (C) 2008-2016 Free Software Foundation, Inc.
++// Copyright (C) 2008-2017 Free Software Foundation, Inc.
 +
 +// Author: Eric M. Ludlam 
 +
 +// This file is part of GNU Emacs.
 +
 +// GNU Emacs is free software: you can redistribute it and/or modify
 +// it under the terms of the GNU General Public License as published by
 +// the Free Software Foundation, either version 3 of the License, or
 +// (at your option) any later version.
 +
 +// GNU Emacs is distributed in the hope that it will be useful,
 +// but WITHOUT ANY WARRANTY; without even the implied warranty of
 +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +// GNU General Public License for more details.
 +
 +// You should have received a copy of the GNU General Public License
 +// along with GNU Emacs.  If not, see .
 +
 +// Thanks Ming-Wei Chang for these examples.
 +
 +namespace std {
 +  template class basic_string {
 +  public:
 +    void resize(int);
 +  };
 +}
 +
 +typedef std::basic_string mstring;
 +
 +using namespace std;
 +typedef basic_string bstring;
 +
 +int main(){
 +  mstring a;
 +  a.// -1-
 +    ;
 +  // #1# ( "resize" )
 +  bstring b;
 +  // It doesn't work here.
 +  b.// -2-
 +    ;
 +  // #2# ( "resize" )
 +  return 0;
 +}
 +
 +// ------------------
 +
 +class Bar
 +{
 +public:
 +     void someFunc() {}
 +};
 +
 +typedef Bar new_Bar;
 +
 +template 
 +class TBar
 +{
 +public:
 +     void otherFunc() {}
 +};
 +
 +typedef TBar new_TBar;
 +
 +int main()
 +{
 +  new_Bar nb;
 +  new_TBar ntb;
 +
 +  nb.// -3-
 +    ;
 +  // #3# ("someFunc")
 +  ntb.// -4-
 +    ;
 +  // #4# ("otherFunc")
 +  return 0;
 +}
 +
diff --cc test/manual/cedet/tests/testvarnames.c
index 419361d1dbc,00000000000..dbc4afb46ba
mode 100644,000000..100644
--- a/test/manual/cedet/tests/testvarnames.c
+++ b/test/manual/cedet/tests/testvarnames.c
@@@ -1,90 -1,0 +1,90 @@@
 +/* testvarnames.cpp
 +   Test variable and function names, lists of variables on one line, etc.
 +
-    Copyright (C) 2008-2016 Free Software Foundation, Inc.
++   Copyright (C) 2008-2017 Free Software Foundation, Inc.
 +
 +   Author: Eric M. Ludlam 
 +
 +   This file is part of GNU Emacs.
 +
 +   GNU Emacs is free software: you can redistribute it and/or modify
 +   it under the terms of the GNU General Public License as published by
 +   the Free Software Foundation, either version 3 of the License, or
 +   (at your option) any later version.
 +
 +   GNU Emacs is distributed in the hope that it will be useful,
 +   but WITHOUT ANY WARRANTY; without even the implied warranty of
 +   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +   GNU General Public License for more details.
 +
 +   You should have received a copy of the GNU General Public License
 +   along with GNU Emacs.  If not, see .
 +*/
 +
 +struct independent {
 +  int indep_1;
 +  int indep_2;
 +};
 +
 +struct independent var_indep_struct;
 +
 +struct {
 +  int unnamed_1;
 +  int unnamed_2;
 +} var_unnamed_struct;
 +
 +struct {
 +  int unnamed_3;
 +  int unnamed_4;
 +} var_un_2, var_un_3;
 +
 +struct inlinestruct {
 +  int named_1;
 +  int named_2;
 +} var_named_struct;
 +
 +struct inline2struct {
 +  int named_3;
 +  int named_4;
 +} var_n_2, var_n_3;
 +
 +/* Structures with names that then declare variables
 + * should also be completable.
 + *
 + * Getting this to work is the bugfix in semantic-c.el CVS v 1.122
 + */
 +struct inlinestruct in_var1;
 +struct inline2struct in_var2;
 +
 +int test_1(int var_arg1) {
 +
 +  var_// -1-
 +    ; // #1# ("var_arg1" "var_indep_struct" "var_n_2" "var_n_3" "var_named_struct" "var_un_2" "var_un_3" "var_unnamed_struct")
 +
 +  var_indep_struct.// -2-
 +    ; // #2# ( "indep_1" "indep_2" )
 +
 +  var_unnamed_struct.// -3-
 +    ; // #3# ( "unnamed_1" "unnamed_2" )
 +
 +  var_named_struct.// -4-
 +    ; // #4# ( "named_1" "named_2" )
 +
 +  var_un_2.// -5-
 +    ; // #5# ( "unnamed_3" "unnamed_4" )
 +  var_un_3.// -6-
 +    ; // #6# ( "unnamed_3" "unnamed_4" )
 +
 +  var_n_2.// -7-
 +    ; // #7# ( "named_3" "named_4" )
 +  var_n_3.// -8-
 +    ; // #8# ( "named_3" "named_4" )
 +
 +  in_// -9-
 +    ; // #9# ( "in_var1" "in_var2" )
 +
 +  in_var1.// -10-
 +    ; // #10# ( "named_1" "named_2")
 +  in_var2.// -11-
 +    ; // #11# ( "named_3" "named_4")
 +}
diff --cc test/manual/etags/c-src/abbrev.c
index b7d137cd9bd,00000000000..c01eee419ff
mode 100644,000000..100644
--- a/test/manual/etags/c-src/abbrev.c
+++ b/test/manual/etags/c-src/abbrev.c
@@@ -1,617 -1,0 +1,617 @@@
 +/* Primitives for word-abbrev mode.
-    Copyright (C) 1985-1986, 1993, 1996, 1998, 2016 Free Software
++   Copyright (C) 1985-1986, 1993, 1996, 1998, 2016-2017 Free Software
 +   Foundation, Inc.
 +
 +This file is part of GNU Emacs.
 +
 +GNU Emacs is free software; you can redistribute it and/or modify
 +it under the terms of the GNU General Public License as published by
 +the Free Software Foundation; either version 2, or (at your option)
 +any later version.
 +
 +GNU Emacs is distributed in the hope that it will be useful,
 +but WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +GNU General Public License for more details.
 +
 +You should have received a copy of the GNU General Public License
 +along with GNU Emacs; see the file COPYING.  If not, write to
 +the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 +Boston, MA 02111-1307, USA.  */
 +
 +
 +#include 
 +#include 
 +#include "lisp.h"
 +#include "commands.h"
 +#include "buffer.h"
 +#include "window.h"
 +#include "charset.h"
 +#include "syntax.h"
 +
 +/* An abbrev table is an obarray.
 + Each defined abbrev is represented by a symbol in that obarray
 + whose print name is the abbreviation.
 + The symbol's value is a string which is the expansion.
 + If its function definition is non-nil, it is called
 +  after the expansion is done.
 + The plist slot of the abbrev symbol is its usage count. */
 +
 +/* List of all abbrev-table name symbols:
 + symbols whose values are abbrev tables.  */
 +
 +Lisp_Object Vabbrev_table_name_list;
 +
 +/* The table of global abbrevs.  These are in effect
 + in any buffer in which abbrev mode is turned on. */
 +
 +Lisp_Object Vglobal_abbrev_table;
 +
 +/* The local abbrev table used by default (in Fundamental Mode buffers) */
 +
 +Lisp_Object Vfundamental_mode_abbrev_table;
 +
 +/* Set nonzero when an abbrev definition is changed */
 +
 +int abbrevs_changed;
 +
 +int abbrev_all_caps;
 +
 +/* Non-nil => use this location as the start of abbrev to expand
 + (rather than taking the word before point as the abbrev) */
 +
 +Lisp_Object Vabbrev_start_location;
 +
 +/* Buffer that Vabbrev_start_location applies to */
 +Lisp_Object Vabbrev_start_location_buffer;
 +
 +/* The symbol representing the abbrev most recently expanded */
 +
 +Lisp_Object Vlast_abbrev;
 +
 +/* A string for the actual text of the abbrev most recently expanded.
 +   This has more info than Vlast_abbrev since case is significant.  */
 +
 +Lisp_Object Vlast_abbrev_text;
 +
 +/* Character address of start of last abbrev expanded */
 +
 +int last_abbrev_point;
 +
 +/* Hook to run before expanding any abbrev.  */
 +
 +Lisp_Object Vpre_abbrev_expand_hook, Qpre_abbrev_expand_hook;
 +
 +DEFUN ("make-abbrev-table", Fmake_abbrev_table, Smake_abbrev_table, 0, 0, 0,
 +  "Create a new, empty abbrev table object.")
 +  ()
 +{
 +  return Fmake_vector (make_number (59), make_number (0));
 +}
 +
 +DEFUN ("clear-abbrev-table", Fclear_abbrev_table, Sclear_abbrev_table, 1, 1, 0,
 +  "Undefine all abbrevs in abbrev table TABLE, leaving it empty.")
 +  (table)
 +     Lisp_Object table;
 +{
 +  int i, size;
 +
 +  CHECK_VECTOR (table, 0);
 +  size = XVECTOR (table)->size;
 +  abbrevs_changed = 1;
 +  for (i = 0; i < size; i++)
 +    XVECTOR (table)->contents[i] = make_number (0);
 +  return Qnil;
 +}
 +
 +DEFUN ("define-abbrev", Fdefine_abbrev, Sdefine_abbrev, 3, 5, 0,
 +  "Define an abbrev in TABLE named NAME, to expand to EXPANSION and call HOOK.\n\
 +NAME must be a string.\n\
 +EXPANSION should usually be a string.\n\
 +To undefine an abbrev, define it with EXPANSION = nil.\n\
 +If HOOK is non-nil, it should be a function of no arguments;\n\
 +it is called after EXPANSION is inserted.\n\
 +If EXPANSION is not a string, the abbrev is a special one,\n\
 + which does not expand in the usual way but only runs HOOK.\n\
 +COUNT, if specified, initializes the abbrev's usage-count\n\
 +which is incremented each time the abbrev is used.")
 +  (table, name, expansion, hook, count)
 +     Lisp_Object table, name, expansion, hook, count;
 +{
 +  Lisp_Object sym, oexp, ohook, tem;
 +  CHECK_VECTOR (table, 0);
 +  CHECK_STRING (name, 1);
 +
 +  if (NILP (count))
 +    count = make_number (0);
 +  else
 +    CHECK_NUMBER (count, 0);
 +
 +  sym = Fintern (name, table);
 +
 +  oexp = XSYMBOL (sym)->value;
 +  ohook = XSYMBOL (sym)->function;
 +  if (!((EQ (oexp, expansion)
 +	 || (STRINGP (oexp) && STRINGP (expansion)
 +	     && (tem = Fstring_equal (oexp, expansion), !NILP (tem))))
 +	&&
 +	(EQ (ohook, hook)
 +	 || (tem = Fequal (ohook, hook), !NILP (tem)))))
 +    abbrevs_changed = 1;
 +
 +  Fset (sym, expansion);
 +  Ffset (sym, hook);
 +  Fsetplist (sym, count);
 +
 +  return name;
 +}
 +
 +DEFUN ("define-global-abbrev", Fdefine_global_abbrev, Sdefine_global_abbrev, 2, 2,
 +  "sDefine global abbrev: \nsExpansion for %s: ",
 +  "Define ABBREV as a global abbreviation for EXPANSION.")
 +  (abbrev, expansion)
 +     Lisp_Object abbrev, expansion;
 +{
 +  Fdefine_abbrev (Vglobal_abbrev_table, Fdowncase (abbrev),
 +		  expansion, Qnil, make_number (0));
 +  return abbrev;
 +}
 +
 +DEFUN ("define-mode-abbrev", Fdefine_mode_abbrev, Sdefine_mode_abbrev, 2, 2,
 +  "sDefine mode abbrev: \nsExpansion for %s: ",
 +  "Define ABBREV as a mode-specific abbreviation for EXPANSION.")
 +  (abbrev, expansion)
 +     Lisp_Object abbrev, expansion;
 +{
 +  if (NILP (current_buffer->abbrev_table))
 +    error ("Major mode has no abbrev table");
 +
 +  Fdefine_abbrev (current_buffer->abbrev_table, Fdowncase (abbrev),
 +		  expansion, Qnil, make_number (0));
 +  return abbrev;
 +}
 +
 +DEFUN ("abbrev-symbol", Fabbrev_symbol, Sabbrev_symbol, 1, 2, 0,
 +  "Return the symbol representing abbrev named ABBREV.\n\
 +This symbol's name is ABBREV, but it is not the canonical symbol of that name;\n\
 +it is interned in an abbrev-table rather than the normal obarray.\n\
 +The value is nil if that abbrev is not defined.\n\
 +Optional second arg TABLE is abbrev table to look it up in.\n\
 +The default is to try buffer's mode-specific abbrev table, then global table.")
 +  (abbrev, table)
 +     Lisp_Object abbrev, table;
 +{
 +  Lisp_Object sym;
 +  CHECK_STRING (abbrev, 0);
 +  if (!NILP (table))
 +    sym = Fintern_soft (abbrev, table);
 +  else
 +    {
 +      sym = Qnil;
 +      if (!NILP (current_buffer->abbrev_table))
 +	sym = Fintern_soft (abbrev, current_buffer->abbrev_table);
 +      if (NILP (XSYMBOL (sym)->value))
 +	sym = Qnil;
 +      if (NILP (sym))
 +	sym = Fintern_soft (abbrev, Vglobal_abbrev_table);
 +    }
 +  if (NILP (XSYMBOL (sym)->value)) return Qnil;
 +  return sym;
 +}
 +
 +DEFUN ("abbrev-expansion", Fabbrev_expansion, Sabbrev_expansion, 1, 2, 0,
 +  "Return the string that ABBREV expands into in the current buffer.\n\
 +Optionally specify an abbrev table as second arg;\n\
 +then ABBREV is looked up in that table only.")
 +  (abbrev, table)
 +     Lisp_Object abbrev, table;
 +{
 +  Lisp_Object sym;
 +  sym = Fabbrev_symbol (abbrev, table);
 +  if (NILP (sym)) return sym;
 +  return Fsymbol_value (sym);
 +}
 +
 +/* Expand the word before point, if it is an abbrev.
 +  Returns 1 if an expansion is done. */
 +
 +DEFUN ("expand-abbrev", Fexpand_abbrev, Sexpand_abbrev, 0, 0, "",
 +  "Expand the abbrev before point, if there is an abbrev there.\n\
 +Effective when explicitly called even when `abbrev-mode' is nil.\n\
 +Returns the abbrev symbol, if expansion took place.")
 +  ()
 +{
 +  register char *buffer, *p;
 +  int wordstart, wordend;
 +  register int wordstart_byte, wordend_byte, idx;
 +  int whitecnt;
 +  int uccount = 0, lccount = 0;
 +  register Lisp_Object sym;
 +  Lisp_Object expansion, hook, tem;
 +  Lisp_Object value;
 +
 +  value = Qnil;
 +
 +  if (!NILP (Vrun_hooks))
 +    call1 (Vrun_hooks, Qpre_abbrev_expand_hook);
 +
 +  wordstart = 0;
 +  if (!(BUFFERP (Vabbrev_start_location_buffer)
 +	&& XBUFFER (Vabbrev_start_location_buffer) == current_buffer))
 +    Vabbrev_start_location = Qnil;
 +  if (!NILP (Vabbrev_start_location))
 +    {
 +      tem = Vabbrev_start_location;
 +      CHECK_NUMBER_COERCE_MARKER (tem, 0);
 +      wordstart = XINT (tem);
 +      Vabbrev_start_location = Qnil;
 +      if (wordstart < BEGV || wordstart > ZV)
 +	wordstart = 0;
 +      if (wordstart && wordstart != ZV)
 +	{
 +	  wordstart_byte = CHAR_TO_BYTE (wordstart);
 +	  if (FETCH_BYTE (wordstart_byte) == '-')
 +	    del_range (wordstart, wordstart + 1);
 +	}
 +    }
 +  if (!wordstart)
 +    wordstart = scan_words (PT, -1);
 +
 +  if (!wordstart)
 +    return value;
 +
 +  wordstart_byte = CHAR_TO_BYTE (wordstart);
 +  wordend = scan_words (wordstart, 1);
 +  if (!wordend)
 +    return value;
 +
 +  if (wordend > PT)
 +    wordend = PT;
 +
 +  wordend_byte = CHAR_TO_BYTE (wordend);
 +  whitecnt = PT - wordend;
 +  if (wordend <= wordstart)
 +    return value;
 +
 +  p = buffer = (char *) alloca (wordend_byte - wordstart_byte);
 +
 +  for (idx = wordstart_byte; idx < wordend_byte; idx++)
 +    {
 +      /* ??? This loop needs to go by characters!  */
 +      register int c = FETCH_BYTE (idx);
 +      if (UPPERCASEP (c))
 +	c = DOWNCASE (c), uccount++;
 +      else if (! NOCASEP (c))
 +	lccount++;
 +      *p++ = c;
 +    }
 +
 +  if (VECTORP (current_buffer->abbrev_table))
 +    sym = oblookup (current_buffer->abbrev_table, buffer,
 +		    wordend - wordstart, wordend_byte - wordstart_byte);
 +  else
 +    XSETFASTINT (sym, 0);
 +  if (INTEGERP (sym) || NILP (XSYMBOL (sym)->value))
 +    sym = oblookup (Vglobal_abbrev_table, buffer,
 +		    wordend - wordstart, wordend_byte - wordstart_byte);
 +  if (INTEGERP (sym) || NILP (XSYMBOL (sym)->value))
 +    return value;
 +
 +  if (INTERACTIVE && !EQ (minibuf_window, selected_window))
 +    {
 +      /* Add an undo boundary, in case we are doing this for
 +	 a self-inserting command which has avoided making one so far.  */
 +      SET_PT (wordend);
 +      Fundo_boundary ();
 +    }
 +
 +  Vlast_abbrev_text
 +    = Fbuffer_substring (make_number (wordstart), make_number (wordend));
 +
 +  /* Now sym is the abbrev symbol.  */
 +  Vlast_abbrev = sym;
 +  value = sym;
 +  last_abbrev_point = wordstart;
 +
 +  if (INTEGERP (XSYMBOL (sym)->plist))
 +    XSETINT (XSYMBOL (sym)->plist,
 +	     XINT (XSYMBOL (sym)->plist) + 1);	/* Increment use count */
 +
 +  /* If this abbrev has an expansion, delete the abbrev
 +     and insert the expansion.  */
 +  expansion = XSYMBOL (sym)->value;
 +  if (STRINGP (expansion))
 +    {
 +      SET_PT (wordstart);
 +
 +      del_range_both (wordstart, wordstart_byte, wordend, wordend_byte, 1);
 +
 +      insert_from_string (expansion, 0, 0, XSTRING (expansion)->size,
 +			  STRING_BYTES (XSTRING (expansion)), 1);
 +      SET_PT (PT + whitecnt);
 +
 +      if (uccount && !lccount)
 +	{
 +	  /* Abbrev was all caps */
 +	  /* If expansion is multiple words, normally capitalize each word */
 +	  /* This used to be if (!... && ... >= ...) Fcapitalize; else Fupcase
 +	     but Megatest 68000 compiler can't handle that */
 +	  if (!abbrev_all_caps)
 +	    if (scan_words (PT, -1) > scan_words (wordstart, 1))
 +	      {
 +		Fupcase_initials_region (make_number (wordstart),
 +					 make_number (PT));
 +		goto caped;
 +	      }
 +	  /* If expansion is one word, or if user says so, upcase it all. */
 +	  Fupcase_region (make_number (wordstart), make_number (PT));
 +	caped: ;
 +	}
 +      else if (uccount)
 +	{
 +	  /* Abbrev included some caps.  Cap first initial of expansion */
 +	  int pos = wordstart_byte;
 +
 +	  /* Find the initial.  */
 +	  while (pos < PT_BYTE
 +		 && SYNTAX (*BUF_BYTE_ADDRESS (current_buffer, pos)) != Sword)
 +	    pos++;
 +
 +	  /* Change just that.  */
 +	  pos = BYTE_TO_CHAR (pos);
 +	  Fupcase_initials_region (make_number (pos), make_number (pos + 1));
 +	}
 +    }
 +
 +  hook = XSYMBOL (sym)->function;
 +  if (!NILP (hook))
 +    {
 +      Lisp_Object expanded, prop;
 +
 +      /* If the abbrev has a hook function, run it.  */
 +      expanded = call0 (hook);
 +
 +      /* In addition, if the hook function is a symbol with a a
 +	 non-nil `no-self-insert' property, let the value it returned
 +	 specify whether we consider that an expansion took place.  If
 +	 it returns nil, no expansion has been done.  */
 +
 +      if (SYMBOLP (hook)
 +	  && NILP (expanded)
 +	  && (prop = Fget (hook, intern ("no-self-insert")),
 +	      !NILP (prop)))
 +	value = Qnil;
 +    }
 +
 +  return value;
 +}
 +
 +DEFUN ("unexpand-abbrev", Funexpand_abbrev, Sunexpand_abbrev, 0, 0, "",
 +  "Undo the expansion of the last abbrev that expanded.\n\
 +This differs from ordinary undo in that other editing done since then\n\
 +is not undone.")
 +  ()
 +{
 +  int opoint = PT;
 +  int adjust = 0;
 +  if (last_abbrev_point < BEGV
 +      || last_abbrev_point > ZV)
 +    return Qnil;
 +  SET_PT (last_abbrev_point);
 +  if (STRINGP (Vlast_abbrev_text))
 +    {
 +      /* This isn't correct if Vlast_abbrev->function was used
 +         to do the expansion */
 +      Lisp_Object val;
 +      int zv_before;
 +
 +      val = XSYMBOL (Vlast_abbrev)->value;
 +      if (!STRINGP (val))
 +	error ("value of abbrev-symbol must be a string");
 +      zv_before = ZV;
 +      del_range_byte (PT_BYTE, PT_BYTE + STRING_BYTES (XSTRING (val)), 1);
 +      /* Don't inherit properties here; just copy from old contents.  */
 +      insert_from_string (Vlast_abbrev_text, 0, 0,
 +			  XSTRING (Vlast_abbrev_text)->size,
 +			  STRING_BYTES (XSTRING (Vlast_abbrev_text)), 0);
 +      Vlast_abbrev_text = Qnil;
 +      /* Total number of characters deleted.  */
 +      adjust = ZV - zv_before;
 +    }
 +  SET_PT (last_abbrev_point < opoint ? opoint + adjust : opoint);
 +  return Qnil;
 +}
 +
 +static void
 +write_abbrev (sym, stream)
 +     Lisp_Object sym, stream;
 +{
 +  Lisp_Object name;
 +  if (NILP (XSYMBOL (sym)->value))
 +    return;
 +  insert ("    (", 5);
 +  XSETSTRING (name, XSYMBOL (sym)->name);
 +  Fprin1 (name, stream);
 +  insert (" ", 1);
 +  Fprin1 (XSYMBOL (sym)->value, stream);
 +  insert (" ", 1);
 +  Fprin1 (XSYMBOL (sym)->function, stream);
 +  insert (" ", 1);
 +  Fprin1 (XSYMBOL (sym)->plist, stream);
 +  insert (")\n", 2);
 +}
 +
 +static void
 +describe_abbrev (sym, stream)
 +     Lisp_Object sym, stream;
 +{
 +  Lisp_Object one;
 +
 +  if (NILP (XSYMBOL (sym)->value))
 +    return;
 +  one = make_number (1);
 +  Fprin1 (Fsymbol_name (sym), stream);
 +  Findent_to (make_number (15), one);
 +  Fprin1 (XSYMBOL (sym)->plist, stream);
 +  Findent_to (make_number (20), one);
 +  Fprin1 (XSYMBOL (sym)->value, stream);
 +  if (!NILP (XSYMBOL (sym)->function))
 +    {
 +      Findent_to (make_number (45), one);
 +      Fprin1 (XSYMBOL (sym)->function, stream);
 +    }
 +  Fterpri (stream);
 +}
 +
 +DEFUN ("insert-abbrev-table-description", Finsert_abbrev_table_description,
 +  Sinsert_abbrev_table_description, 1, 2, 0,
 +  "Insert before point a full description of abbrev table named NAME.\n\
 +NAME is a symbol whose value is an abbrev table.\n\
 +If optional 2nd arg READABLE is non-nil, a human-readable description\n\
 +is inserted.  Otherwise the description is an expression,\n\
 +a call to `define-abbrev-table', which would\n\
 +define the abbrev table NAME exactly as it is currently defined.")
 +  (name, readable)
 +     Lisp_Object name, readable;
 +{
 +  Lisp_Object table;
 +  Lisp_Object stream;
 +
 +  CHECK_SYMBOL (name, 0);
 +  table = Fsymbol_value (name);
 +  CHECK_VECTOR (table, 0);
 +
 +  XSETBUFFER (stream, current_buffer);
 +
 +  if (!NILP (readable))
 +    {
 +      insert_string ("(");
 +      Fprin1 (name, stream);
 +      insert_string (")\n\n");
 +      map_obarray (table, describe_abbrev, stream);
 +      insert_string ("\n\n");
 +    }
 +  else
 +    {
 +      insert_string ("(define-abbrev-table '");
 +      Fprin1 (name, stream);
 +      insert_string (" '(\n");
 +      map_obarray (table, write_abbrev, stream);
 +      insert_string ("    ))\n\n");
 +    }
 +
 +  return Qnil;
 +}
 +
 +DEFUN ("define-abbrev-table", Fdefine_abbrev_table, Sdefine_abbrev_table,
 +       2, 2, 0,
 +  "Define TABLENAME (a symbol) as an abbrev table name.\n\
 +Define abbrevs in it according to DEFINITIONS, which is a list of elements\n\
 +of the form (ABBREVNAME EXPANSION HOOK USECOUNT).")
 +  (tablename, definitions)
 +     Lisp_Object tablename, definitions;
 +{
 +  Lisp_Object name, exp, hook, count;
 +  Lisp_Object table, elt;
 +
 +  CHECK_SYMBOL (tablename, 0);
 +  table = Fboundp (tablename);
 +  if (NILP (table) || (table = Fsymbol_value (tablename), NILP (table)))
 +    {
 +      table = Fmake_abbrev_table ();
 +      Fset (tablename, table);
 +      Vabbrev_table_name_list = Fcons (tablename, Vabbrev_table_name_list);
 +    }
 +  CHECK_VECTOR (table, 0);
 +
 +  for (; !NILP (definitions); definitions = Fcdr (definitions))
 +    {
 +      elt = Fcar (definitions);
 +      name  = Fcar (elt);	elt = Fcdr (elt);
 +      exp   = Fcar (elt);	elt = Fcdr (elt);
 +      hook  = Fcar (elt);	elt = Fcdr (elt);
 +      count = Fcar (elt);
 +      Fdefine_abbrev (table, name, exp, hook, count);
 +    }
 +  return Qnil;
 +}
 +
 +void
 +syms_of_abbrev ()
 +{
 +  DEFVAR_LISP ("abbrev-table-name-list", &Vabbrev_table_name_list,
 +    "List of symbols whose values are abbrev tables.");
 +  Vabbrev_table_name_list = Fcons (intern ("fundamental-mode-abbrev-table"),
 +				   Fcons (intern ("global-abbrev-table"),
 +					  Qnil));
 +
 +  DEFVAR_LISP ("global-abbrev-table", &Vglobal_abbrev_table,
 +    "The abbrev table whose abbrevs affect all buffers.\n\
 +Each buffer may also have a local abbrev table.\n\
 +If it does, the local table overrides the global one\n\
 +for any particular abbrev defined in both.");
 +  Vglobal_abbrev_table = Fmake_abbrev_table ();
 +
 +  DEFVAR_LISP ("fundamental-mode-abbrev-table", &Vfundamental_mode_abbrev_table,
 +    "The abbrev table of mode-specific abbrevs for Fundamental Mode.");
 +  Vfundamental_mode_abbrev_table = Fmake_abbrev_table ();
 +  current_buffer->abbrev_table = Vfundamental_mode_abbrev_table;
 +  buffer_defaults.abbrev_table = Vfundamental_mode_abbrev_table;
 +
 +  DEFVAR_LISP ("last-abbrev", &Vlast_abbrev,
 +    "The abbrev-symbol of the last abbrev expanded.  See `abbrev-symbol'.");
 +
 +  DEFVAR_LISP ("last-abbrev-text", &Vlast_abbrev_text,
 +    "The exact text of the last abbrev expanded.\n\
 +nil if the abbrev has already been unexpanded.");
 +
 +  DEFVAR_INT ("last-abbrev-location", &last_abbrev_point,
 +    "The location of the start of the last abbrev expanded.");
 +
 +  Vlast_abbrev = Qnil;
 +  Vlast_abbrev_text = Qnil;
 +  last_abbrev_point = 0;
 +
 +  DEFVAR_LISP ("abbrev-start-location", &Vabbrev_start_location,
 +    "Buffer position for `expand-abbrev' to use as the start of the abbrev.\n\
 +nil means use the word before point as the abbrev.\n\
 +Calling `expand-abbrev' sets this to nil.");
 +  Vabbrev_start_location = Qnil;
 +
 +  DEFVAR_LISP ("abbrev-start-location-buffer", &Vabbrev_start_location_buffer,
 +    "Buffer that `abbrev-start-location' has been set for.\n\
 +Trying to expand an abbrev in any other buffer clears `abbrev-start-location'.");
 +  Vabbrev_start_location_buffer = Qnil;
 +
 +  DEFVAR_PER_BUFFER ("local-abbrev-table", ¤t_buffer->abbrev_table, Qnil,
 +    "Local (mode-specific) abbrev table of current buffer.");
 +
 +  DEFVAR_BOOL ("abbrevs-changed", &abbrevs_changed,
 +    "Set non-nil by defining or altering any word abbrevs.\n\
 +This causes `save-some-buffers' to offer to save the abbrevs.");
 +  abbrevs_changed = 0;
 +
 +  DEFVAR_BOOL ("abbrev-all-caps", &abbrev_all_caps,
 +    "*Set non-nil means expand multi-word abbrevs all caps if abbrev was so.");
 +  abbrev_all_caps = 0;
 +
 +  DEFVAR_LISP ("pre-abbrev-expand-hook", &Vpre_abbrev_expand_hook,
 +    "Function or functions to be called before abbrev expansion is done.\n\
 +This is the first thing that `expand-abbrev' does, and so this may change\n\
 +the current abbrev table before abbrev lookup happens.");
 +  Vpre_abbrev_expand_hook = Qnil;
 +  Qpre_abbrev_expand_hook = intern ("pre-abbrev-expand-hook");
 +  staticpro (&Qpre_abbrev_expand_hook);
 +
 +  defsubr (&Smake_abbrev_table);
 +  defsubr (&Sclear_abbrev_table);
 +  defsubr (&Sdefine_abbrev);
 +  defsubr (&Sdefine_global_abbrev);
 +  defsubr (&Sdefine_mode_abbrev);
 +  defsubr (&Sabbrev_expansion);
 +  defsubr (&Sabbrev_symbol);
 +  defsubr (&Sexpand_abbrev);
 +  defsubr (&Sunexpand_abbrev);
 +  defsubr (&Sinsert_abbrev_table_description);
 +  defsubr (&Sdefine_abbrev_table);
 +}
diff --cc test/manual/etags/c-src/emacs/src/gmalloc.c
index 683ee0c9502,00000000000..79b2040e321
mode 100644,000000..100644
--- a/test/manual/etags/c-src/emacs/src/gmalloc.c
+++ b/test/manual/etags/c-src/emacs/src/gmalloc.c
@@@ -1,2040 -1,0 +1,2040 @@@
 +/* Declarations for `malloc' and friends.
-    Copyright (C) 1990-1993, 1995-1996, 1999, 2002-2007, 2013-2016 Free
++   Copyright (C) 1990-1993, 1995-1996, 1999, 2002-2007, 2013-2017 Free
 +   Software Foundation, Inc.
 +		  Written May 1989 by Mike Haertel.
 +
 +This library is free software; you can redistribute it and/or
 +modify it under the terms of the GNU General Public License as
 +published by the Free Software Foundation; either version 2 of the
 +License, or (at your option) any later version.
 +
 +This library is distributed in the hope that it will be useful,
 +but WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 +General Public License for more details.
 +
 +You should have received a copy of the GNU General Public
 +License along with this library.  If not, see .
 +
 +   The author may be reached (Email) at the address mike@ai.mit.edu,
 +   or (US mail) as Mike Haertel c/o Free Software Foundation.  */
 +
 +#include 
 +
 +#if defined HAVE_PTHREAD && !defined HYBRID_MALLOC
 +#define USE_PTHREAD
 +#endif
 +
 +#include 
 +#include 
 +#include 
 +
 +#ifdef HYBRID_GET_CURRENT_DIR_NAME
 +#undef get_current_dir_name
 +#endif
 +
 +#include 
 +
 +#ifdef USE_PTHREAD
 +#include 
 +#endif
 +
 +#ifdef WINDOWSNT
 +#include 	/* for sbrk */
 +#endif
 +
 +#ifdef emacs
 +extern void emacs_abort (void);
 +#endif
 +
 +/* If HYBRID_MALLOC is defined, then temacs will use malloc,
 +   realloc... as defined in this file (and renamed gmalloc,
 +   grealloc... via the macros that follow).  The dumped emacs,
 +   however, will use the system malloc, realloc....  In other source
 +   files, malloc, realloc... are renamed hybrid_malloc,
 +   hybrid_realloc... via macros in conf_post.h.  hybrid_malloc and
 +   friends are wrapper functions defined later in this file.
 +   aligned_alloc is defined as a macro only in alloc.c.
 +
 +   As of this writing (August 2014), Cygwin is the only platform on
 +   which HYBRID_MACRO is defined.  Any other platform that wants to
 +   define it will have to define the macros DUMPED and
 +   ALLOCATED_BEFORE_DUMPING, defined below for Cygwin.  */
 +#ifdef HYBRID_MALLOC
 +#undef malloc
 +#undef realloc
 +#undef calloc
 +#undef free
 +#define malloc gmalloc
 +#define realloc grealloc
 +#define calloc gcalloc
 +#define aligned_alloc galigned_alloc
 +#define free gfree
 +#endif  /* HYBRID_MALLOC */
 +
 +#ifdef CYGWIN
 +extern void *bss_sbrk (ptrdiff_t size);
 +extern int bss_sbrk_did_unexec;
 +extern char bss_sbrk_buffer[];
 +extern void *bss_sbrk_buffer_end;
 +#define DUMPED bss_sbrk_did_unexec
 +#define ALLOCATED_BEFORE_DUMPING(P) \
 +  ((P) < bss_sbrk_buffer_end && (P) >= (void *) bss_sbrk_buffer)
 +#endif
 +
 +#ifdef	__cplusplus
 +extern "C"
 +{
 +#endif
 +
 +#include 
 +
 +
 +/* Allocate SIZE bytes of memory.  */
 +extern void *malloc (size_t size) ATTRIBUTE_MALLOC_SIZE ((1));
 +/* Re-allocate the previously allocated block
 +   in ptr, making the new block SIZE bytes long.  */
 +extern void *realloc (void *ptr, size_t size) ATTRIBUTE_ALLOC_SIZE ((2));
 +/* Allocate NMEMB elements of SIZE bytes each, all initialized to 0.  */
 +extern void *calloc (size_t nmemb, size_t size) ATTRIBUTE_MALLOC_SIZE ((1,2));
 +/* Free a block allocated by `malloc', `realloc' or `calloc'.  */
 +extern void free (void *ptr);
 +
 +/* Allocate SIZE bytes allocated to ALIGNMENT bytes.  */
 +#ifdef MSDOS
 +extern void *aligned_alloc (size_t, size_t);
 +extern void *memalign (size_t, size_t);
 +extern int posix_memalign (void **, size_t, size_t);
 +#endif
 +
 +#ifdef USE_PTHREAD
 +/* Set up mutexes and make malloc etc. thread-safe.  */
 +extern void malloc_enable_thread (void);
 +#endif
 +
 +#ifdef emacs
 +extern void emacs_abort (void);
 +#endif
 +
 +/* The allocator divides the heap into blocks of fixed size; large
 +   requests receive one or more whole blocks, and small requests
 +   receive a fragment of a block.  Fragment sizes are powers of two,
 +   and all fragments of a block are the same size.  When all the
 +   fragments in a block have been freed, the block itself is freed.  */
 +#define INT_BIT		(CHAR_BIT * sizeof (int))
 +#define BLOCKLOG	(INT_BIT > 16 ? 12 : 9)
 +#define BLOCKSIZE	(1 << BLOCKLOG)
 +#define BLOCKIFY(SIZE)	(((SIZE) + BLOCKSIZE - 1) / BLOCKSIZE)
 +
 +/* Determine the amount of memory spanned by the initial heap table
 +   (not an absolute limit).  */
 +#define HEAP		(INT_BIT > 16 ? 4194304 : 65536)
 +
 +/* Number of contiguous free blocks allowed to build up at the end of
 +   memory before they will be returned to the system.  */
 +#define FINAL_FREE_BLOCKS	8
 +
 +/* Data structure giving per-block information.  */
 +typedef union
 +  {
 +    /* Heap information for a busy block.  */
 +    struct
 +      {
 +	/* Zero for a large (multiblock) object, or positive giving the
 +	   logarithm to the base two of the fragment size.  */
 +	int type;
 +	union
 +	  {
 +	    struct
 +	      {
 +		size_t nfree; /* Free frags in a fragmented block.  */
 +		size_t first; /* First free fragment of the block.  */
 +	      } frag;
 +	    /* For a large object, in its first block, this has the number
 +	       of blocks in the object.  In the other blocks, this has a
 +	       negative number which says how far back the first block is.  */
 +	    ptrdiff_t size;
 +	  } info;
 +      } busy;
 +    /* Heap information for a free block
 +       (that may be the first of a free cluster).  */
 +    struct
 +      {
 +	size_t size;	/* Size (in blocks) of a free cluster.  */
 +	size_t next;	/* Index of next free cluster.  */
 +	size_t prev;	/* Index of previous free cluster.  */
 +      } free;
 +  } malloc_info;
 +
 +/* Pointer to first block of the heap.  */
 +extern char *_heapbase;
 +
 +/* Table indexed by block number giving per-block information.  */
 +extern malloc_info *_heapinfo;
 +
 +/* Address to block number and vice versa.  */
 +#define BLOCK(A)	(((char *) (A) - _heapbase) / BLOCKSIZE + 1)
 +#define ADDRESS(B)	((void *) (((B) - 1) * BLOCKSIZE + _heapbase))
 +
 +/* Current search index for the heap table.  */
 +extern size_t _heapindex;
 +
 +/* Limit of valid info table indices.  */
 +extern size_t _heaplimit;
 +
 +/* Doubly linked lists of free fragments.  */
 +struct list
 +  {
 +    struct list *next;
 +    struct list *prev;
 +  };
 +
 +/* Free list headers for each fragment size.  */
 +extern struct list _fraghead[];
 +
 +/* List of blocks allocated with aligned_alloc and friends.  */
 +struct alignlist
 +  {
 +    struct alignlist *next;
 +    void *aligned;		/* The address that aligned_alloc returned.  */
 +    void *exact;		/* The address that malloc returned.  */
 +  };
 +extern struct alignlist *_aligned_blocks;
 +
 +/* Instrumentation.  */
 +extern size_t _chunks_used;
 +extern size_t _bytes_used;
 +extern size_t _chunks_free;
 +extern size_t _bytes_free;
 +
 +/* Internal versions of `malloc', `realloc', and `free'
 +   used when these functions need to call each other.
 +   They are the same but don't call the hooks.  */
 +extern void *_malloc_internal (size_t);
 +extern void *_realloc_internal (void *, size_t);
 +extern void _free_internal (void *);
 +extern void *_malloc_internal_nolock (size_t);
 +extern void *_realloc_internal_nolock (void *, size_t);
 +extern void _free_internal_nolock (void *);
 +
 +#ifdef USE_PTHREAD
 +extern pthread_mutex_t _malloc_mutex, _aligned_blocks_mutex;
 +extern int _malloc_thread_enabled_p;
 +#define LOCK()					\
 +  do {						\
 +    if (_malloc_thread_enabled_p)		\
 +      pthread_mutex_lock (&_malloc_mutex);	\
 +  } while (0)
 +#define UNLOCK()				\
 +  do {						\
 +    if (_malloc_thread_enabled_p)		\
 +      pthread_mutex_unlock (&_malloc_mutex);	\
 +  } while (0)
 +#define LOCK_ALIGNED_BLOCKS()				\
 +  do {							\
 +    if (_malloc_thread_enabled_p)			\
 +      pthread_mutex_lock (&_aligned_blocks_mutex);	\
 +  } while (0)
 +#define UNLOCK_ALIGNED_BLOCKS()				\
 +  do {							\
 +    if (_malloc_thread_enabled_p)			\
 +      pthread_mutex_unlock (&_aligned_blocks_mutex);	\
 +  } while (0)
 +#else
 +#define LOCK()
 +#define UNLOCK()
 +#define LOCK_ALIGNED_BLOCKS()
 +#define UNLOCK_ALIGNED_BLOCKS()
 +#endif
 +
 +/* Given an address in the middle of a malloc'd object,
 +   return the address of the beginning of the object.  */
 +extern void *malloc_find_object_address (void *ptr);
 +
 +/* Underlying allocation function; successive calls should
 +   return contiguous pieces of memory.  */
 +extern void *(*__morecore) (ptrdiff_t size);
 +
 +/* Default value of `__morecore'.  */
 +extern void *__default_morecore (ptrdiff_t size);
 +
 +/* If not NULL, this function is called after each time
 +   `__morecore' is called to increase the data size.  */
 +extern void (*__after_morecore_hook) (void);
 +
 +/* Number of extra blocks to get each time we ask for more core.
 +   This reduces the frequency of calling `(*__morecore)'.  */
 +extern size_t __malloc_extra_blocks;
 +
 +/* Nonzero if `malloc' has been called and done its initialization.  */
 +extern int __malloc_initialized;
 +/* Function called to initialize malloc data structures.  */
 +extern int __malloc_initialize (void);
 +
 +/* Hooks for debugging versions.  */
 +extern void (*__malloc_initialize_hook) (void);
 +extern void (*__free_hook) (void *ptr);
 +extern void *(*__malloc_hook) (size_t size);
 +extern void *(*__realloc_hook) (void *ptr, size_t size);
 +extern void *(*__memalign_hook) (size_t size, size_t alignment);
 +
 +/* Return values for `mprobe': these are the kinds of inconsistencies that
 +   `mcheck' enables detection of.  */
 +enum mcheck_status
 +  {
 +    MCHECK_DISABLED = -1,	/* Consistency checking is not turned on.  */
 +    MCHECK_OK,			/* Block is fine.  */
 +    MCHECK_FREE,		/* Block freed twice.  */
 +    MCHECK_HEAD,		/* Memory before the block was clobbered.  */
 +    MCHECK_TAIL			/* Memory after the block was clobbered.  */
 +  };
 +
 +/* Activate a standard collection of debugging hooks.  This must be called
 +   before `malloc' is ever called.  ABORTFUNC is called with an error code
 +   (see enum above) when an inconsistency is detected.  If ABORTFUNC is
 +   null, the standard function prints on stderr and then calls `abort'.  */
 +extern int mcheck (void (*abortfunc) (enum mcheck_status));
 +
 +/* Check for aberrations in a particular malloc'd block.  You must have
 +   called `mcheck' already.  These are the same checks that `mcheck' does
 +   when you free or reallocate a block.  */
 +extern enum mcheck_status mprobe (void *ptr);
 +
 +/* Activate a standard collection of tracing hooks.  */
 +extern void mtrace (void);
 +extern void muntrace (void);
 +
 +/* Statistics available to the user.  */
 +struct mstats
 +  {
 +    size_t bytes_total;	/* Total size of the heap. */
 +    size_t chunks_used;	/* Chunks allocated by the user. */
 +    size_t bytes_used;	/* Byte total of user-allocated chunks. */
 +    size_t chunks_free;	/* Chunks in the free list. */
 +    size_t bytes_free;	/* Byte total of chunks in the free list. */
 +  };
 +
 +/* Pick up the current statistics. */
 +extern struct mstats mstats (void);
 +
 +/* Call WARNFUN with a warning message when memory usage is high.  */
 +extern void memory_warnings (void *start, void (*warnfun) (const char *));
 +
 +#ifdef	__cplusplus
 +}
 +#endif
 +
 +/* Memory allocator `malloc'.
 +   Copyright 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
 +		  Written May 1989 by Mike Haertel.
 +
 +This library is free software; you can redistribute it and/or
 +modify it under the terms of the GNU General Public License as
 +published by the Free Software Foundation; either version 2 of the
 +License, or (at your option) any later version.
 +
 +This library is distributed in the hope that it will be useful,
 +but WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 +General Public License for more details.
 +
 +You should have received a copy of the GNU General Public
 +License along with this library.  If not, see .
 +
 +   The author may be reached (Email) at the address mike@ai.mit.edu,
 +   or (US mail) as Mike Haertel c/o Free Software Foundation.  */
 +
 +#include 
 +
 +void *(*__morecore) (ptrdiff_t size) = __default_morecore;
 +
 +/* Debugging hook for `malloc'.  */
 +void *(*__malloc_hook) (size_t size);
 +
 +/* Pointer to the base of the first block.  */
 +char *_heapbase;
 +
 +/* Block information table.  Allocated with align/__free (not malloc/free).  */
 +malloc_info *_heapinfo;
 +
 +/* Number of info entries.  */
 +static size_t heapsize;
 +
 +/* Search index in the info table.  */
 +size_t _heapindex;
 +
 +/* Limit of valid info table indices.  */
 +size_t _heaplimit;
 +
 +/* Free lists for each fragment size.  */
 +struct list _fraghead[BLOCKLOG];
 +
 +/* Instrumentation.  */
 +size_t _chunks_used;
 +size_t _bytes_used;
 +size_t _chunks_free;
 +size_t _bytes_free;
 +
 +/* Are you experienced?  */
 +int __malloc_initialized;
 +
 +size_t __malloc_extra_blocks;
 +
 +void (*__malloc_initialize_hook) (void);
 +void (*__after_morecore_hook) (void);
 +
 +#if defined GC_MALLOC_CHECK && defined GC_PROTECT_MALLOC_STATE
 +
 +/* Some code for hunting a bug writing into _heapinfo.
 +
 +   Call this macro with argument PROT non-zero to protect internal
 +   malloc state against writing to it, call it with a zero argument to
 +   make it readable and writable.
 +
 +   Note that this only works if BLOCKSIZE == page size, which is
 +   the case on the i386.  */
 +
 +#include 
 +#include 
 +
 +static int state_protected_p;
 +static size_t last_state_size;
 +static malloc_info *last_heapinfo;
 +
 +void
 +protect_malloc_state (int protect_p)
 +{
 +  /* If _heapinfo has been relocated, make sure its old location
 +     isn't left read-only; it will be reused by malloc.  */
 +  if (_heapinfo != last_heapinfo
 +      && last_heapinfo
 +      && state_protected_p)
 +    mprotect (last_heapinfo, last_state_size, PROT_READ | PROT_WRITE);
 +
 +  last_state_size = _heaplimit * sizeof *_heapinfo;
 +  last_heapinfo   = _heapinfo;
 +
 +  if (protect_p != state_protected_p)
 +    {
 +      state_protected_p = protect_p;
 +      if (mprotect (_heapinfo, last_state_size,
 +		    protect_p ? PROT_READ : PROT_READ | PROT_WRITE) != 0)
 +	abort ();
 +    }
 +}
 +
 +#define PROTECT_MALLOC_STATE(PROT) protect_malloc_state (PROT)
 +
 +#else
 +#define PROTECT_MALLOC_STATE(PROT)	/* empty */
 +#endif
 +
 +
 +/* Aligned allocation.  */
 +static void *
 +align (size_t size)
 +{
 +  void *result;
 +  ptrdiff_t adj;
 +
 +  /* align accepts an unsigned argument, but __morecore accepts a
 +     signed one.  This could lead to trouble if SIZE overflows the
 +     ptrdiff_t type accepted by __morecore.  We just punt in that
 +     case, since they are requesting a ludicrous amount anyway.  */
 +  if (PTRDIFF_MAX < size)
 +    result = 0;
 +  else
 +    result = (*__morecore) (size);
 +  adj = (uintptr_t) result % BLOCKSIZE;
 +  if (adj != 0)
 +    {
 +      adj = BLOCKSIZE - adj;
 +      (*__morecore) (adj);
 +      result = (char *) result + adj;
 +    }
 +
 +  if (__after_morecore_hook)
 +    (*__after_morecore_hook) ();
 +
 +  return result;
 +}
 +
 +/* Get SIZE bytes, if we can get them starting at END.
 +   Return the address of the space we got.
 +   If we cannot get space at END, fail and return 0.  */
 +static void *
 +get_contiguous_space (ptrdiff_t size, void *position)
 +{
 +  void *before;
 +  void *after;
 +
 +  before = (*__morecore) (0);
 +  /* If we can tell in advance that the break is at the wrong place,
 +     fail now.  */
 +  if (before != position)
 +    return 0;
 +
 +  /* Allocate SIZE bytes and get the address of them.  */
 +  after = (*__morecore) (size);
 +  if (!after)
 +    return 0;
 +
 +  /* It was not contiguous--reject it.  */
 +  if (after != position)
 +    {
 +      (*__morecore) (- size);
 +      return 0;
 +    }
 +
 +  return after;
 +}
 +
 +
 +/* This is called when `_heapinfo' and `heapsize' have just
 +   been set to describe a new info table.  Set up the table
 +   to describe itself and account for it in the statistics.  */
 +static void
 +register_heapinfo (void)
 +{
 +  size_t block, blocks;
 +
 +  block = BLOCK (_heapinfo);
 +  blocks = BLOCKIFY (heapsize * sizeof (malloc_info));
 +
 +  /* Account for the _heapinfo block itself in the statistics.  */
 +  _bytes_used += blocks * BLOCKSIZE;
 +  ++_chunks_used;
 +
 +  /* Describe the heapinfo block itself in the heapinfo.  */
 +  _heapinfo[block].busy.type = 0;
 +  _heapinfo[block].busy.info.size = blocks;
 +  /* Leave back-pointers for malloc_find_address.  */
 +  while (--blocks > 0)
 +    _heapinfo[block + blocks].busy.info.size = -blocks;
 +}
 +
 +#ifdef USE_PTHREAD
 +pthread_mutex_t _malloc_mutex = PTHREAD_MUTEX_INITIALIZER;
 +pthread_mutex_t _aligned_blocks_mutex = PTHREAD_MUTEX_INITIALIZER;
 +int _malloc_thread_enabled_p;
 +
 +static void
 +malloc_atfork_handler_prepare (void)
 +{
 +  LOCK ();
 +  LOCK_ALIGNED_BLOCKS ();
 +}
 +
 +static void
 +malloc_atfork_handler_parent (void)
 +{
 +  UNLOCK_ALIGNED_BLOCKS ();
 +  UNLOCK ();
 +}
 +
 +static void
 +malloc_atfork_handler_child (void)
 +{
 +  UNLOCK_ALIGNED_BLOCKS ();
 +  UNLOCK ();
 +}
 +
 +/* Set up mutexes and make malloc etc. thread-safe.  */
 +void
 +malloc_enable_thread (void)
 +{
 +  if (_malloc_thread_enabled_p)
 +    return;
 +
 +  /* Some pthread implementations call malloc for statically
 +     initialized mutexes when they are used first.  To avoid such a
 +     situation, we initialize mutexes here while their use is
 +     disabled in malloc etc.  */
 +  pthread_mutex_init (&_malloc_mutex, NULL);
 +  pthread_mutex_init (&_aligned_blocks_mutex, NULL);
 +  pthread_atfork (malloc_atfork_handler_prepare,
 +		  malloc_atfork_handler_parent,
 +		  malloc_atfork_handler_child);
 +  _malloc_thread_enabled_p = 1;
 +}
 +#endif	/* USE_PTHREAD */
 +
 +static void
 +malloc_initialize_1 (void)
 +{
 +#ifdef GC_MCHECK
 +  mcheck (NULL);
 +#endif
 +
 +  if (__malloc_initialize_hook)
 +    (*__malloc_initialize_hook) ();
 +
 +  heapsize = HEAP / BLOCKSIZE;
 +  _heapinfo = align (heapsize * sizeof (malloc_info));
 +  if (_heapinfo == NULL)
 +    return;
 +  memset (_heapinfo, 0, heapsize * sizeof (malloc_info));
 +  _heapinfo[0].free.size = 0;
 +  _heapinfo[0].free.next = _heapinfo[0].free.prev = 0;
 +  _heapindex = 0;
 +  _heapbase = (char *) _heapinfo;
 +  _heaplimit = BLOCK (_heapbase + heapsize * sizeof (malloc_info));
 +
 +  register_heapinfo ();
 +
 +  __malloc_initialized = 1;
 +  PROTECT_MALLOC_STATE (1);
 +  return;
 +}
 +
 +/* Set everything up and remember that we have.
 +   main will call malloc which calls this function.  That is before any threads
 +   or signal handlers has been set up, so we don't need thread protection.  */
 +int
 +__malloc_initialize (void)
 +{
 +  if (__malloc_initialized)
 +    return 0;
 +
 +  malloc_initialize_1 ();
 +
 +  return __malloc_initialized;
 +}
 +
 +static int morecore_recursing;
 +
 +/* Get neatly aligned memory, initializing or
 +   growing the heap info table as necessary. */
 +static void *
 +morecore_nolock (size_t size)
 +{
 +  void *result;
 +  malloc_info *newinfo, *oldinfo;
 +  size_t newsize;
 +
 +  if (morecore_recursing)
 +    /* Avoid recursion.  The caller will know how to handle a null return.  */
 +    return NULL;
 +
 +  result = align (size);
 +  if (result == NULL)
 +    return NULL;
 +
 +  PROTECT_MALLOC_STATE (0);
 +
 +  /* Check if we need to grow the info table.  */
 +  if ((size_t) BLOCK ((char *) result + size) > heapsize)
 +    {
 +      /* Calculate the new _heapinfo table size.  We do not account for the
 +	 added blocks in the table itself, as we hope to place them in
 +	 existing free space, which is already covered by part of the
 +	 existing table.  */
 +      newsize = heapsize;
 +      do
 +	newsize *= 2;
 +      while ((size_t) BLOCK ((char *) result + size) > newsize);
 +
 +      /* We must not reuse existing core for the new info table when called
 +	 from realloc in the case of growing a large block, because the
 +	 block being grown is momentarily marked as free.  In this case
 +	 _heaplimit is zero so we know not to reuse space for internal
 +	 allocation.  */
 +      if (_heaplimit != 0)
 +	{
 +	  /* First try to allocate the new info table in core we already
 +	     have, in the usual way using realloc.  If realloc cannot
 +	     extend it in place or relocate it to existing sufficient core,
 +	     we will get called again, and the code above will notice the
 +	     `morecore_recursing' flag and return null.  */
 +	  int save = errno;	/* Don't want to clobber errno with ENOMEM.  */
 +	  morecore_recursing = 1;
 +	  newinfo = _realloc_internal_nolock (_heapinfo,
 +					      newsize * sizeof (malloc_info));
 +	  morecore_recursing = 0;
 +	  if (newinfo == NULL)
 +	    errno = save;
 +	  else
 +	    {
 +	      /* We found some space in core, and realloc has put the old
 +		 table's blocks on the free list.  Now zero the new part
 +		 of the table and install the new table location.  */
 +	      memset (&newinfo[heapsize], 0,
 +		      (newsize - heapsize) * sizeof (malloc_info));
 +	      _heapinfo = newinfo;
 +	      heapsize = newsize;
 +	      goto got_heap;
 +	    }
 +	}
 +
 +      /* Allocate new space for the malloc info table.  */
 +      while (1)
 +  	{
 + 	  newinfo = align (newsize * sizeof (malloc_info));
 +
 + 	  /* Did it fail?  */
 + 	  if (newinfo == NULL)
 + 	    {
 + 	      (*__morecore) (-size);
 + 	      return NULL;
 + 	    }
 +
 + 	  /* Is it big enough to record status for its own space?
 + 	     If so, we win.  */
 + 	  if ((size_t) BLOCK ((char *) newinfo
 +			      + newsize * sizeof (malloc_info))
 + 	      < newsize)
 + 	    break;
 +
 + 	  /* Must try again.  First give back most of what we just got.  */
 + 	  (*__morecore) (- newsize * sizeof (malloc_info));
 + 	  newsize *= 2;
 +  	}
 +
 +      /* Copy the old table to the beginning of the new,
 +	 and zero the rest of the new table.  */
 +      memcpy (newinfo, _heapinfo, heapsize * sizeof (malloc_info));
 +      memset (&newinfo[heapsize], 0,
 +	      (newsize - heapsize) * sizeof (malloc_info));
 +      oldinfo = _heapinfo;
 +      _heapinfo = newinfo;
 +      heapsize = newsize;
 +
 +      register_heapinfo ();
 +
 +      /* Reset _heaplimit so _free_internal never decides
 +	 it can relocate or resize the info table.  */
 +      _heaplimit = 0;
 +      _free_internal_nolock (oldinfo);
 +      PROTECT_MALLOC_STATE (0);
 +
 +      /* The new heap limit includes the new table just allocated.  */
 +      _heaplimit = BLOCK ((char *) newinfo + heapsize * sizeof (malloc_info));
 +      return result;
 +    }
 +
 + got_heap:
 +  _heaplimit = BLOCK ((char *) result + size);
 +  return result;
 +}
 +
 +/* Allocate memory from the heap.  */
 +void *
 +_malloc_internal_nolock (size_t size)
 +{
 +  void *result;
 +  size_t block, blocks, lastblocks, start;
 +  register size_t i;
 +  struct list *next;
 +
 +  /* ANSI C allows `malloc (0)' to either return NULL, or to return a
 +     valid address you can realloc and free (though not dereference).
 +
 +     It turns out that some extant code (sunrpc, at least Ultrix's version)
 +     expects `malloc (0)' to return non-NULL and breaks otherwise.
 +     Be compatible.  */
 +
 +#if	0
 +  if (size == 0)
 +    return NULL;
 +#endif
 +
 +  PROTECT_MALLOC_STATE (0);
 +
 +  if (size < sizeof (struct list))
 +    size = sizeof (struct list);
 +
 +  /* Determine the allocation policy based on the request size.  */
 +  if (size <= BLOCKSIZE / 2)
 +    {
 +      /* Small allocation to receive a fragment of a block.
 +	 Determine the logarithm to base two of the fragment size. */
 +      register size_t log = 1;
 +      --size;
 +      while ((size /= 2) != 0)
 +	++log;
 +
 +      /* Look in the fragment lists for a
 +	 free fragment of the desired size. */
 +      next = _fraghead[log].next;
 +      if (next != NULL)
 +	{
 +	  /* There are free fragments of this size.
 +	     Pop a fragment out of the fragment list and return it.
 +	     Update the block's nfree and first counters. */
 +	  result = next;
 +	  next->prev->next = next->next;
 +	  if (next->next != NULL)
 +	    next->next->prev = next->prev;
 +	  block = BLOCK (result);
 +	  if (--_heapinfo[block].busy.info.frag.nfree != 0)
 +	    _heapinfo[block].busy.info.frag.first =
 +	      (uintptr_t) next->next % BLOCKSIZE >> log;
 +
 +	  /* Update the statistics.  */
 +	  ++_chunks_used;
 +	  _bytes_used += 1 << log;
 +	  --_chunks_free;
 +	  _bytes_free -= 1 << log;
 +	}
 +      else
 +	{
 +	  /* No free fragments of the desired size, so get a new block
 +	     and break it into fragments, returning the first.  */
 +#ifdef GC_MALLOC_CHECK
 +	  result = _malloc_internal_nolock (BLOCKSIZE);
 +	  PROTECT_MALLOC_STATE (0);
 +#elif defined (USE_PTHREAD)
 +	  result = _malloc_internal_nolock (BLOCKSIZE);
 +#else
 +	  result = malloc (BLOCKSIZE);
 +#endif
 +	  if (result == NULL)
 +	    {
 +	      PROTECT_MALLOC_STATE (1);
 +	      goto out;
 +	    }
 +
 +	  /* Link all fragments but the first into the free list.  */
 +	  next = (struct list *) ((char *) result + (1 << log));
 +	  next->next = NULL;
 +	  next->prev = &_fraghead[log];
 +	  _fraghead[log].next = next;
 +
 +	  for (i = 2; i < (size_t) (BLOCKSIZE >> log); ++i)
 +	    {
 +	      next = (struct list *) ((char *) result + (i << log));
 +	      next->next = _fraghead[log].next;
 +	      next->prev = &_fraghead[log];
 +	      next->prev->next = next;
 +	      next->next->prev = next;
 +	    }
 +
 +	  /* Initialize the nfree and first counters for this block.  */
 +	  block = BLOCK (result);
 +	  _heapinfo[block].busy.type = log;
 +	  _heapinfo[block].busy.info.frag.nfree = i - 1;
 +	  _heapinfo[block].busy.info.frag.first = i - 1;
 +
 +	  _chunks_free += (BLOCKSIZE >> log) - 1;
 +	  _bytes_free += BLOCKSIZE - (1 << log);
 +	  _bytes_used -= BLOCKSIZE - (1 << log);
 +	}
 +    }
 +  else
 +    {
 +      /* Large allocation to receive one or more blocks.
 +	 Search the free list in a circle starting at the last place visited.
 +	 If we loop completely around without finding a large enough
 +	 space we will have to get more memory from the system.  */
 +      blocks = BLOCKIFY (size);
 +      start = block = _heapindex;
 +      while (_heapinfo[block].free.size < blocks)
 +	{
 +	  block = _heapinfo[block].free.next;
 +	  if (block == start)
 +	    {
 +	      /* Need to get more from the system.  Get a little extra.  */
 +	      size_t wantblocks = blocks + __malloc_extra_blocks;
 +	      block = _heapinfo[0].free.prev;
 +	      lastblocks = _heapinfo[block].free.size;
 +	      /* Check to see if the new core will be contiguous with the
 +		 final free block; if so we don't need to get as much.  */
 +	      if (_heaplimit != 0 && block + lastblocks == _heaplimit &&
 +		  /* We can't do this if we will have to make the heap info
 +                     table bigger to accommodate the new space.  */
 +		  block + wantblocks <= heapsize &&
 +		  get_contiguous_space ((wantblocks - lastblocks) * BLOCKSIZE,
 +					ADDRESS (block + lastblocks)))
 +		{
 + 		  /* We got it contiguously.  Which block we are extending
 +		     (the `final free block' referred to above) might have
 +		     changed, if it got combined with a freed info table.  */
 + 		  block = _heapinfo[0].free.prev;
 +  		  _heapinfo[block].free.size += (wantblocks - lastblocks);
 +		  _bytes_free += (wantblocks - lastblocks) * BLOCKSIZE;
 + 		  _heaplimit += wantblocks - lastblocks;
 +		  continue;
 +		}
 +	      result = morecore_nolock (wantblocks * BLOCKSIZE);
 +	      if (result == NULL)
 +		goto out;
 +	      block = BLOCK (result);
 +	      /* Put the new block at the end of the free list.  */
 +	      _heapinfo[block].free.size = wantblocks;
 +	      _heapinfo[block].free.prev = _heapinfo[0].free.prev;
 +	      _heapinfo[block].free.next = 0;
 +	      _heapinfo[0].free.prev = block;
 +	      _heapinfo[_heapinfo[block].free.prev].free.next = block;
 +	      ++_chunks_free;
 +	      /* Now loop to use some of that block for this allocation.  */
 +	    }
 +	}
 +
 +      /* At this point we have found a suitable free list entry.
 +	 Figure out how to remove what we need from the list. */
 +      result = ADDRESS (block);
 +      if (_heapinfo[block].free.size > blocks)
 +	{
 +	  /* The block we found has a bit left over,
 +	     so relink the tail end back into the free list. */
 +	  _heapinfo[block + blocks].free.size
 +	    = _heapinfo[block].free.size - blocks;
 +	  _heapinfo[block + blocks].free.next
 +	    = _heapinfo[block].free.next;
 +	  _heapinfo[block + blocks].free.prev
 +	    = _heapinfo[block].free.prev;
 +	  _heapinfo[_heapinfo[block].free.prev].free.next
 +	    = _heapinfo[_heapinfo[block].free.next].free.prev
 +	    = _heapindex = block + blocks;
 +	}
 +      else
 +	{
 +	  /* The block exactly matches our requirements,
 +	     so just remove it from the list. */
 +	  _heapinfo[_heapinfo[block].free.next].free.prev
 +	    = _heapinfo[block].free.prev;
 +	  _heapinfo[_heapinfo[block].free.prev].free.next
 +	    = _heapindex = _heapinfo[block].free.next;
 +	  --_chunks_free;
 +	}
 +
 +      _heapinfo[block].busy.type = 0;
 +      _heapinfo[block].busy.info.size = blocks;
 +      ++_chunks_used;
 +      _bytes_used += blocks * BLOCKSIZE;
 +      _bytes_free -= blocks * BLOCKSIZE;
 +
 +      /* Mark all the blocks of the object just allocated except for the
 +	 first with a negative number so you can find the first block by
 +	 adding that adjustment.  */
 +      while (--blocks > 0)
 +	_heapinfo[block + blocks].busy.info.size = -blocks;
 +    }
 +
 +  PROTECT_MALLOC_STATE (1);
 + out:
 +  return result;
 +}
 +
 +void *
 +_malloc_internal (size_t size)
 +{
 +  void *result;
 +
 +  LOCK ();
 +  result = _malloc_internal_nolock (size);
 +  UNLOCK ();
 +
 +  return result;
 +}
 +
 +void *
 +malloc (size_t size)
 +{
 +  void *(*hook) (size_t);
 +
 +  if (!__malloc_initialized && !__malloc_initialize ())
 +    return NULL;
 +
 +  /* Copy the value of __malloc_hook to an automatic variable in case
 +     __malloc_hook is modified in another thread between its
 +     NULL-check and the use.
 +
 +     Note: Strictly speaking, this is not a right solution.  We should
 +     use mutexes to access non-read-only variables that are shared
 +     among multiple threads.  We just leave it for compatibility with
 +     glibc malloc (i.e., assignments to __malloc_hook) for now.  */
 +  hook = __malloc_hook;
 +  return (hook != NULL ? *hook : _malloc_internal) (size);
 +}
 +
 +#ifndef _LIBC
 +
 +/* On some ANSI C systems, some libc functions call _malloc, _free
 +   and _realloc.  Make them use the GNU functions.  */
 +
 +extern void *_malloc (size_t);
 +extern void _free (void *);
 +extern void *_realloc (void *, size_t);
 +
 +void *
 +_malloc (size_t size)
 +{
 +  return malloc (size);
 +}
 +
 +void
 +_free (void *ptr)
 +{
 +  free (ptr);
 +}
 +
 +void *
 +_realloc (void *ptr, size_t size)
 +{
 +  return realloc (ptr, size);
 +}
 +
 +#endif
 +/* Free a block of memory allocated by `malloc'.
 +   Copyright 1990, 1991, 1992, 1994, 1995 Free Software Foundation, Inc.
 +		  Written May 1989 by Mike Haertel.
 +
 +This library is free software; you can redistribute it and/or
 +modify it under the terms of the GNU General Public License as
 +published by the Free Software Foundation; either version 2 of the
 +License, or (at your option) any later version.
 +
 +This library is distributed in the hope that it will be useful,
 +but WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 +General Public License for more details.
 +
 +You should have received a copy of the GNU General Public
 +License along with this library.  If not, see .
 +
 +   The author may be reached (Email) at the address mike@ai.mit.edu,
 +   or (US mail) as Mike Haertel c/o Free Software Foundation.  */
 +
 +
 +/* Debugging hook for free.  */
 +void (*__free_hook) (void *__ptr);
 +
 +/* List of blocks allocated by aligned_alloc.  */
 +struct alignlist *_aligned_blocks = NULL;
 +
 +/* Return memory to the heap.
 +   Like `_free_internal' but don't lock mutex.  */
 +void
 +_free_internal_nolock (void *ptr)
 +{
 +  int type;
 +  size_t block, blocks;
 +  register size_t i;
 +  struct list *prev, *next;
 +  void *curbrk;
 +  const size_t lesscore_threshold
 +    /* Threshold of free space at which we will return some to the system.  */
 +    = FINAL_FREE_BLOCKS + 2 * __malloc_extra_blocks;
 +
 +  register struct alignlist *l;
 +
 +  if (ptr == NULL)
 +    return;
 +
 +  PROTECT_MALLOC_STATE (0);
 +
 +  LOCK_ALIGNED_BLOCKS ();
 +  for (l = _aligned_blocks; l != NULL; l = l->next)
 +    if (l->aligned == ptr)
 +      {
 +	l->aligned = NULL;	/* Mark the slot in the list as free.  */
 +	ptr = l->exact;
 +	break;
 +      }
 +  UNLOCK_ALIGNED_BLOCKS ();
 +
 +  block = BLOCK (ptr);
 +
 +  type = _heapinfo[block].busy.type;
 +  switch (type)
 +    {
 +    case 0:
 +      /* Get as many statistics as early as we can.  */
 +      --_chunks_used;
 +      _bytes_used -= _heapinfo[block].busy.info.size * BLOCKSIZE;
 +      _bytes_free += _heapinfo[block].busy.info.size * BLOCKSIZE;
 +
 +      /* Find the free cluster previous to this one in the free list.
 +	 Start searching at the last block referenced; this may benefit
 +	 programs with locality of allocation.  */
 +      i = _heapindex;
 +      if (i > block)
 +	while (i > block)
 +	  i = _heapinfo[i].free.prev;
 +      else
 +	{
 +	  do
 +	    i = _heapinfo[i].free.next;
 +	  while (i > 0 && i < block);
 +	  i = _heapinfo[i].free.prev;
 +	}
 +
 +      /* Determine how to link this block into the free list.  */
 +      if (block == i + _heapinfo[i].free.size)
 +	{
 +	  /* Coalesce this block with its predecessor.  */
 +	  _heapinfo[i].free.size += _heapinfo[block].busy.info.size;
 +	  block = i;
 +	}
 +      else
 +	{
 +	  /* Really link this block back into the free list.  */
 +	  _heapinfo[block].free.size = _heapinfo[block].busy.info.size;
 +	  _heapinfo[block].free.next = _heapinfo[i].free.next;
 +	  _heapinfo[block].free.prev = i;
 +	  _heapinfo[i].free.next = block;
 +	  _heapinfo[_heapinfo[block].free.next].free.prev = block;
 +	  ++_chunks_free;
 +	}
 +
 +      /* Now that the block is linked in, see if we can coalesce it
 +	 with its successor (by deleting its successor from the list
 +	 and adding in its size).  */
 +      if (block + _heapinfo[block].free.size == _heapinfo[block].free.next)
 +	{
 +	  _heapinfo[block].free.size
 +	    += _heapinfo[_heapinfo[block].free.next].free.size;
 +	  _heapinfo[block].free.next
 +	    = _heapinfo[_heapinfo[block].free.next].free.next;
 +	  _heapinfo[_heapinfo[block].free.next].free.prev = block;
 +	  --_chunks_free;
 +	}
 +
 +      /* How many trailing free blocks are there now?  */
 +      blocks = _heapinfo[block].free.size;
 +
 +      /* Where is the current end of accessible core?  */
 +      curbrk = (*__morecore) (0);
 +
 +      if (_heaplimit != 0 && curbrk == ADDRESS (_heaplimit))
 +	{
 +	  /* The end of the malloc heap is at the end of accessible core.
 +	     It's possible that moving _heapinfo will allow us to
 +	     return some space to the system.  */
 +
 + 	  size_t info_block = BLOCK (_heapinfo);
 + 	  size_t info_blocks = _heapinfo[info_block].busy.info.size;
 + 	  size_t prev_block = _heapinfo[block].free.prev;
 + 	  size_t prev_blocks = _heapinfo[prev_block].free.size;
 + 	  size_t next_block = _heapinfo[block].free.next;
 + 	  size_t next_blocks = _heapinfo[next_block].free.size;
 +
 +	  if (/* Win if this block being freed is last in core, the info table
 +		 is just before it, the previous free block is just before the
 +		 info table, and the two free blocks together form a useful
 +		 amount to return to the system.  */
 +	      (block + blocks == _heaplimit &&
 +	       info_block + info_blocks == block &&
 +	       prev_block != 0 && prev_block + prev_blocks == info_block &&
 +	       blocks + prev_blocks >= lesscore_threshold) ||
 +	      /* Nope, not the case.  We can also win if this block being
 +		 freed is just before the info table, and the table extends
 +		 to the end of core or is followed only by a free block,
 +		 and the total free space is worth returning to the system.  */
 +	      (block + blocks == info_block &&
 +	       ((info_block + info_blocks == _heaplimit &&
 +		 blocks >= lesscore_threshold) ||
 +		(info_block + info_blocks == next_block &&
 +		 next_block + next_blocks == _heaplimit &&
 +		 blocks + next_blocks >= lesscore_threshold)))
 +	      )
 +	    {
 +	      malloc_info *newinfo;
 +	      size_t oldlimit = _heaplimit;
 +
 +	      /* Free the old info table, clearing _heaplimit to avoid
 +		 recursion into this code.  We don't want to return the
 +		 table's blocks to the system before we have copied them to
 +		 the new location.  */
 +	      _heaplimit = 0;
 +	      _free_internal_nolock (_heapinfo);
 +	      _heaplimit = oldlimit;
 +
 +	      /* Tell malloc to search from the beginning of the heap for
 +		 free blocks, so it doesn't reuse the ones just freed.  */
 +	      _heapindex = 0;
 +
 +	      /* Allocate new space for the info table and move its data.  */
 +	      newinfo = _malloc_internal_nolock (info_blocks * BLOCKSIZE);
 +	      PROTECT_MALLOC_STATE (0);
 +	      memmove (newinfo, _heapinfo, info_blocks * BLOCKSIZE);
 +	      _heapinfo = newinfo;
 +
 +	      /* We should now have coalesced the free block with the
 +		 blocks freed from the old info table.  Examine the entire
 +		 trailing free block to decide below whether to return some
 +		 to the system.  */
 +	      block = _heapinfo[0].free.prev;
 +	      blocks = _heapinfo[block].free.size;
 + 	    }
 +
 +	  /* Now see if we can return stuff to the system.  */
 +	  if (block + blocks == _heaplimit && blocks >= lesscore_threshold)
 +	    {
 +	      register size_t bytes = blocks * BLOCKSIZE;
 +	      _heaplimit -= blocks;
 +	      (*__morecore) (-bytes);
 +	      _heapinfo[_heapinfo[block].free.prev].free.next
 +		= _heapinfo[block].free.next;
 +	      _heapinfo[_heapinfo[block].free.next].free.prev
 +		= _heapinfo[block].free.prev;
 +	      block = _heapinfo[block].free.prev;
 +	      --_chunks_free;
 +	      _bytes_free -= bytes;
 +	    }
 +	}
 +
 +      /* Set the next search to begin at this block.  */
 +      _heapindex = block;
 +      break;
 +
 +    default:
 +      /* Do some of the statistics.  */
 +      --_chunks_used;
 +      _bytes_used -= 1 << type;
 +      ++_chunks_free;
 +      _bytes_free += 1 << type;
 +
 +      /* Get the address of the first free fragment in this block.  */
 +      prev = (struct list *) ((char *) ADDRESS (block) +
 +			      (_heapinfo[block].busy.info.frag.first << type));
 +
 +      if (_heapinfo[block].busy.info.frag.nfree == (BLOCKSIZE >> type) - 1)
 +	{
 +	  /* If all fragments of this block are free, remove them
 +	     from the fragment list and free the whole block.  */
 +	  next = prev;
 +	  for (i = 1; i < (size_t) (BLOCKSIZE >> type); ++i)
 +	    next = next->next;
 +	  prev->prev->next = next;
 +	  if (next != NULL)
 +	    next->prev = prev->prev;
 +	  _heapinfo[block].busy.type = 0;
 +	  _heapinfo[block].busy.info.size = 1;
 +
 +	  /* Keep the statistics accurate.  */
 +	  ++_chunks_used;
 +	  _bytes_used += BLOCKSIZE;
 +	  _chunks_free -= BLOCKSIZE >> type;
 +	  _bytes_free -= BLOCKSIZE;
 +
 +#if defined (GC_MALLOC_CHECK) || defined (USE_PTHREAD)
 +	  _free_internal_nolock (ADDRESS (block));
 +#else
 +	  free (ADDRESS (block));
 +#endif
 +	}
 +      else if (_heapinfo[block].busy.info.frag.nfree != 0)
 +	{
 +	  /* If some fragments of this block are free, link this
 +	     fragment into the fragment list after the first free
 +	     fragment of this block. */
 +	  next = ptr;
 +	  next->next = prev->next;
 +	  next->prev = prev;
 +	  prev->next = next;
 +	  if (next->next != NULL)
 +	    next->next->prev = next;
 +	  ++_heapinfo[block].busy.info.frag.nfree;
 +	}
 +      else
 +	{
 +	  /* No fragments of this block are free, so link this
 +	     fragment into the fragment list and announce that
 +	     it is the first free fragment of this block. */
 +	  prev = ptr;
 +	  _heapinfo[block].busy.info.frag.nfree = 1;
 +	  _heapinfo[block].busy.info.frag.first =
 +	    (uintptr_t) ptr % BLOCKSIZE >> type;
 +	  prev->next = _fraghead[type].next;
 +	  prev->prev = &_fraghead[type];
 +	  prev->prev->next = prev;
 +	  if (prev->next != NULL)
 +	    prev->next->prev = prev;
 +	}
 +      break;
 +    }
 +
 +  PROTECT_MALLOC_STATE (1);
 +}
 +
 +/* Return memory to the heap.
 +   Like `free' but don't call a __free_hook if there is one.  */
 +void
 +_free_internal (void *ptr)
 +{
 +  LOCK ();
 +  _free_internal_nolock (ptr);
 +  UNLOCK ();
 +}
 +
 +/* Return memory to the heap.  */
 +
 +void
 +free (void *ptr)
 +{
 +  void (*hook) (void *) = __free_hook;
 +
 +  if (hook != NULL)
 +    (*hook) (ptr);
 +  else
 +    _free_internal (ptr);
 +}
 +
 +/* Define the `cfree' alias for `free'.  */
 +#ifdef weak_alias
 +weak_alias (free, cfree)
 +#else
 +void
 +cfree (void *ptr)
 +{
 +  free (ptr);
 +}
 +#endif
 +/* Change the size of a block allocated by `malloc'.
 +   Copyright 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
 +		     Written May 1989 by Mike Haertel.
 +
 +This library is free software; you can redistribute it and/or
 +modify it under the terms of the GNU General Public License as
 +published by the Free Software Foundation; either version 2 of the
 +License, or (at your option) any later version.
 +
 +This library is distributed in the hope that it will be useful,
 +but WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 +General Public License for more details.
 +
 +You should have received a copy of the GNU General Public
 +License along with this library.  If not, see .
 +
 +   The author may be reached (Email) at the address mike@ai.mit.edu,
 +   or (US mail) as Mike Haertel c/o Free Software Foundation.  */
 +
 +#ifndef min
 +#define min(a, b) ((a) < (b) ? (a) : (b))
 +#endif
 +
 +/* Debugging hook for realloc.  */
 +void *(*__realloc_hook) (void *ptr, size_t size);
 +
 +/* Resize the given region to the new size, returning a pointer
 +   to the (possibly moved) region.  This is optimized for speed;
 +   some benchmarks seem to indicate that greater compactness is
 +   achieved by unconditionally allocating and copying to a
 +   new region.  This module has incestuous knowledge of the
 +   internals of both free and malloc. */
 +void *
 +_realloc_internal_nolock (void *ptr, size_t size)
 +{
 +  void *result;
 +  int type;
 +  size_t block, blocks, oldlimit;
 +
 +  if (size == 0)
 +    {
 +      _free_internal_nolock (ptr);
 +      return _malloc_internal_nolock (0);
 +    }
 +  else if (ptr == NULL)
 +    return _malloc_internal_nolock (size);
 +
 +  block = BLOCK (ptr);
 +
 +  PROTECT_MALLOC_STATE (0);
 +
 +  type = _heapinfo[block].busy.type;
 +  switch (type)
 +    {
 +    case 0:
 +      /* Maybe reallocate a large block to a small fragment.  */
 +      if (size <= BLOCKSIZE / 2)
 +	{
 +	  result = _malloc_internal_nolock (size);
 +	  if (result != NULL)
 +	    {
 +	      memcpy (result, ptr, size);
 +	      _free_internal_nolock (ptr);
 +	      goto out;
 +	    }
 +	}
 +
 +      /* The new size is a large allocation as well;
 +	 see if we can hold it in place. */
 +      blocks = BLOCKIFY (size);
 +      if (blocks < _heapinfo[block].busy.info.size)
 +	{
 +	  /* The new size is smaller; return
 +	     excess memory to the free list. */
 +	  _heapinfo[block + blocks].busy.type = 0;
 +	  _heapinfo[block + blocks].busy.info.size
 +	    = _heapinfo[block].busy.info.size - blocks;
 +	  _heapinfo[block].busy.info.size = blocks;
 +	  /* We have just created a new chunk by splitting a chunk in two.
 +	     Now we will free this chunk; increment the statistics counter
 +	     so it doesn't become wrong when _free_internal decrements it.  */
 +	  ++_chunks_used;
 +	  _free_internal_nolock (ADDRESS (block + blocks));
 +	  result = ptr;
 +	}
 +      else if (blocks == _heapinfo[block].busy.info.size)
 +	/* No size change necessary.  */
 +	result = ptr;
 +      else
 +	{
 +	  /* Won't fit, so allocate a new region that will.
 +	     Free the old region first in case there is sufficient
 +	     adjacent free space to grow without moving. */
 +	  blocks = _heapinfo[block].busy.info.size;
 +	  /* Prevent free from actually returning memory to the system.  */
 +	  oldlimit = _heaplimit;
 +	  _heaplimit = 0;
 +	  _free_internal_nolock (ptr);
 +	  result = _malloc_internal_nolock (size);
 +	  PROTECT_MALLOC_STATE (0);
 +	  if (_heaplimit == 0)
 +	    _heaplimit = oldlimit;
 +	  if (result == NULL)
 +	    {
 +	      /* Now we're really in trouble.  We have to unfree
 +		 the thing we just freed.  Unfortunately it might
 +		 have been coalesced with its neighbors.  */
 +	      if (_heapindex == block)
 +	        (void) _malloc_internal_nolock (blocks * BLOCKSIZE);
 +	      else
 +		{
 +		  void *previous
 +		    = _malloc_internal_nolock ((block - _heapindex) * BLOCKSIZE);
 +		  (void) _malloc_internal_nolock (blocks * BLOCKSIZE);
 +		  _free_internal_nolock (previous);
 +		}
 +	      goto out;
 +	    }
 +	  if (ptr != result)
 +	    memmove (result, ptr, blocks * BLOCKSIZE);
 +	}
 +      break;
 +
 +    default:
 +      /* Old size is a fragment; type is logarithm
 +	 to base two of the fragment size.  */
 +      if (size > (size_t) (1 << (type - 1)) &&
 +	  size <= (size_t) (1 << type))
 +	/* The new size is the same kind of fragment.  */
 +	result = ptr;
 +      else
 +	{
 +	  /* The new size is different; allocate a new space,
 +	     and copy the lesser of the new size and the old. */
 +	  result = _malloc_internal_nolock (size);
 +	  if (result == NULL)
 +	    goto out;
 +	  memcpy (result, ptr, min (size, (size_t) 1 << type));
 +	  _free_internal_nolock (ptr);
 +	}
 +      break;
 +    }
 +
 +  PROTECT_MALLOC_STATE (1);
 + out:
 +  return result;
 +}
 +
 +void *
 +_realloc_internal (void *ptr, size_t size)
 +{
 +  void *result;
 +
 +  LOCK ();
 +  result = _realloc_internal_nolock (ptr, size);
 +  UNLOCK ();
 +
 +  return result;
 +}
 +
 +void *
 +realloc (void *ptr, size_t size)
 +{
 +  void *(*hook) (void *, size_t);
 +
 +  if (!__malloc_initialized && !__malloc_initialize ())
 +    return NULL;
 +
 +  hook = __realloc_hook;
 +  return (hook != NULL ? *hook : _realloc_internal) (ptr, size);
 +}
 +/* Copyright (C) 1991, 1992, 1994 Free Software Foundation, Inc.
 +
 +This library is free software; you can redistribute it and/or
 +modify it under the terms of the GNU General Public License as
 +published by the Free Software Foundation; either version 2 of the
 +License, or (at your option) any later version.
 +
 +This library is distributed in the hope that it will be useful,
 +but WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 +General Public License for more details.
 +
 +You should have received a copy of the GNU General Public
 +License along with this library.  If not, see .
 +
 +   The author may be reached (Email) at the address mike@ai.mit.edu,
 +   or (US mail) as Mike Haertel c/o Free Software Foundation.  */
 +
 +/* Allocate an array of NMEMB elements each SIZE bytes long.
 +   The entire array is initialized to zeros.  */
 +void *
 +calloc (size_t nmemb, size_t size)
 +{
 +  void *result;
 +  size_t bytes = nmemb * size;
 +
 +  if (size != 0 && bytes / size != nmemb)
 +    {
 +      errno = ENOMEM;
 +      return NULL;
 +    }
 +
 +  result = malloc (bytes);
 +  if (result)
 +    return memset (result, 0, bytes);
 +  return result;
 +}
 +/* Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
 +This file is part of the GNU C Library.
 +
 +The GNU C Library is free software; you can redistribute it and/or modify
 +it under the terms of the GNU General Public License as published by
 +the Free Software Foundation; either version 2, or (at your option)
 +any later version.
 +
 +The GNU C Library is distributed in the hope that it will be useful,
 +but WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +GNU General Public License for more details.
 +
 +You should have received a copy of the GNU General Public License
 +along with the GNU C Library.  If not, see .  */
 +
 +/* uClibc defines __GNU_LIBRARY__, but it is not completely
 +   compatible.  */
 +#if !defined (__GNU_LIBRARY__) || defined (__UCLIBC__)
 +#define	__sbrk	sbrk
 +#else /* __GNU_LIBRARY__ && ! defined (__UCLIBC__) */
 +/* It is best not to declare this and cast its result on foreign operating
 +   systems with potentially hostile include files.  */
 +
 +extern void *__sbrk (ptrdiff_t increment);
 +#endif /* __GNU_LIBRARY__ && ! defined (__UCLIBC__) */
 +
 +/* Allocate INCREMENT more bytes of data space,
 +   and return the start of data space, or NULL on errors.
 +   If INCREMENT is negative, shrink data space.  */
 +void *
 +__default_morecore (ptrdiff_t increment)
 +{
 +  void *result;
 +#if defined (CYGWIN)
 +  if (!DUMPED)
 +    {
 +      return bss_sbrk (increment);
 +    }
 +#endif
 +  result = (void *) __sbrk (increment);
 +  if (result == (void *) -1)
 +    return NULL;
 +  return result;
 +}
 +/* Copyright (C) 1991, 92, 93, 94, 95, 96 Free Software Foundation, Inc.
 +
 +This library is free software; you can redistribute it and/or
 +modify it under the terms of the GNU General Public License as
 +published by the Free Software Foundation; either version 2 of the
 +License, or (at your option) any later version.
 +
 +This library is distributed in the hope that it will be useful,
 +but WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 +General Public License for more details.
 +
 +You should have received a copy of the GNU General Public
 +License along with this library.  If not, see .  */
 +
 +void *(*__memalign_hook) (size_t size, size_t alignment);
 +
 +void *
 +aligned_alloc (size_t alignment, size_t size)
 +{
 +  void *result;
 +  size_t adj, lastadj;
 +  void *(*hook) (size_t, size_t) = __memalign_hook;
 +
 +  if (hook)
 +    return (*hook) (alignment, size);
 +
 +  /* Allocate a block with enough extra space to pad the block with up to
 +     (ALIGNMENT - 1) bytes if necessary.  */
 +  if (- size < alignment)
 +    {
 +      errno = ENOMEM;
 +      return NULL;
 +    }
 +  result = malloc (size + alignment - 1);
 +  if (result == NULL)
 +    return NULL;
 +
 +  /* Figure out how much we will need to pad this particular block
 +     to achieve the required alignment.  */
 +  adj = alignment - (uintptr_t) result % alignment;
 +  if (adj == alignment)
 +    adj = 0;
 +
 +  if (adj != alignment - 1)
 +    {
 +      do
 +	{
 +	  /* Reallocate the block with only as much excess as it
 +	     needs.  */
 +	  free (result);
 +	  result = malloc (size + adj);
 +	  if (result == NULL)	/* Impossible unless interrupted.  */
 +	    return NULL;
 +
 +	  lastadj = adj;
 +	  adj = alignment - (uintptr_t) result % alignment;
 +	  if (adj == alignment)
 +	    adj = 0;
 +	  /* It's conceivable we might have been so unlucky as to get
 +	     a different block with weaker alignment.  If so, this
 +	     block is too short to contain SIZE after alignment
 +	     correction.  So we must try again and get another block,
 +	     slightly larger.  */
 +	} while (adj > lastadj);
 +    }
 +
 +  if (adj != 0)
 +    {
 +      /* Record this block in the list of aligned blocks, so that `free'
 +	 can identify the pointer it is passed, which will be in the middle
 +	 of an allocated block.  */
 +
 +      struct alignlist *l;
 +      LOCK_ALIGNED_BLOCKS ();
 +      for (l = _aligned_blocks; l != NULL; l = l->next)
 +	if (l->aligned == NULL)
 +	  /* This slot is free.  Use it.  */
 +	  break;
 +      if (l == NULL)
 +	{
 +	  l = malloc (sizeof *l);
 +	  if (l != NULL)
 +	    {
 +	      l->next = _aligned_blocks;
 +	      _aligned_blocks = l;
 +	    }
 +	}
 +      if (l != NULL)
 +	{
 +	  l->exact = result;
 +	  result = l->aligned = (char *) result + adj;
 +	}
 +      UNLOCK_ALIGNED_BLOCKS ();
 +      if (l == NULL)
 +	{
 +	  free (result);
 +	  result = NULL;
 +	}
 +    }
 +
 +  return result;
 +}
 +
 +/* An obsolete alias for aligned_alloc, for any old libraries that use
 +   this alias.  */
 +
 +void *
 +memalign (size_t alignment, size_t size)
 +{
 +  return aligned_alloc (alignment, size);
 +}
 +
 +/* If HYBRID_MALLOC is defined, we may want to use the system
 +   posix_memalign below.  */
 +#ifndef HYBRID_MALLOC
 +int
 +posix_memalign (void **memptr, size_t alignment, size_t size)
 +{
 +  void *mem;
 +
 +  if (alignment == 0
 +      || alignment % sizeof (void *) != 0
 +      || (alignment & (alignment - 1)) != 0)
 +    return EINVAL;
 +
 +  mem = aligned_alloc (alignment, size);
 +  if (mem == NULL)
 +    return ENOMEM;
 +
 +  *memptr = mem;
 +
 +  return 0;
 +}
 +#endif
 +
 +/* Allocate memory on a page boundary.
 +   Copyright (C) 1991, 92, 93, 94, 96 Free Software Foundation, Inc.
 +
 +This library is free software; you can redistribute it and/or
 +modify it under the terms of the GNU General Public License as
 +published by the Free Software Foundation; either version 2 of the
 +License, or (at your option) any later version.
 +
 +This library is distributed in the hope that it will be useful,
 +but WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 +General Public License for more details.
 +
 +You should have received a copy of the GNU General Public
 +License along with this library.  If not, see .
 +
 +   The author may be reached (Email) at the address mike@ai.mit.edu,
 +   or (US mail) as Mike Haertel c/o Free Software Foundation.  */
 +
 +/* Allocate SIZE bytes on a page boundary.  */
 +extern void *valloc (size_t);
 +
 +#if defined _SC_PAGESIZE || !defined HAVE_GETPAGESIZE
 +# include "getpagesize.h"
 +#elif !defined getpagesize
 +extern int getpagesize (void);
 +#endif
 +
 +static size_t pagesize;
 +
 +void *
 +valloc (size_t size)
 +{
 +  if (pagesize == 0)
 +    pagesize = getpagesize ();
 +
 +  return aligned_alloc (pagesize, size);
 +}
 +
 +#ifdef HYBRID_MALLOC
 +#undef malloc
 +#undef realloc
 +#undef calloc
 +#undef aligned_alloc
 +#undef free
 +
 +/* Declare system malloc and friends.  */
 +extern void *malloc (size_t size);
 +extern void *realloc (void *ptr, size_t size);
 +extern void *calloc (size_t nmemb, size_t size);
 +extern void free (void *ptr);
 +#ifdef HAVE_ALIGNED_ALLOC
 +extern void *aligned_alloc (size_t alignment, size_t size);
 +#elif defined HAVE_POSIX_MEMALIGN
 +extern int posix_memalign (void **memptr, size_t alignment, size_t size);
 +#endif
 +
 +/* See the comments near the beginning of this file for explanations
 +   of the following functions. */
 +
 +void *
 +hybrid_malloc (size_t size)
 +{
 +  if (DUMPED)
 +    return malloc (size);
 +  return gmalloc (size);
 +}
 +
 +void *
 +hybrid_calloc (size_t nmemb, size_t size)
 +{
 +  if (DUMPED)
 +    return calloc (nmemb, size);
 +  return gcalloc (nmemb, size);
 +}
 +
 +void
 +hybrid_free (void *ptr)
 +{
 +  if (!DUMPED)
 +    gfree (ptr);
 +  else if (!ALLOCATED_BEFORE_DUMPING (ptr))
 +    free (ptr);
 +  /* Otherwise the dumped emacs is trying to free something allocated
 +     before dumping; do nothing.  */
 +  return;
 +}
 +
 +#if defined HAVE_ALIGNED_ALLOC || defined HAVE_POSIX_MEMALIGN
 +void *
 +hybrid_aligned_alloc (size_t alignment, size_t size)
 +{
 +  if (!DUMPED)
 +    return galigned_alloc (alignment, size);
 +  /* The following is copied from alloc.c */
 +#ifdef HAVE_ALIGNED_ALLOC
 +  return aligned_alloc (alignment, size);
 +#else  /* HAVE_POSIX_MEMALIGN */
 +  void *p;
 +  return posix_memalign (&p, alignment, size) == 0 ? p : 0;
 +#endif
 +}
 +#endif
 +  
 +void *
 +hybrid_realloc (void *ptr, size_t size)
 +{
 +  void *result;
 +  int type;
 +  size_t block, oldsize;
 +
 +  if (!DUMPED)
 +    return grealloc (ptr, size);
 +  if (!ALLOCATED_BEFORE_DUMPING (ptr))
 +    return realloc (ptr, size);
 +
 +  /* The dumped emacs is trying to realloc storage allocated before
 +   dumping.  We just malloc new space and copy the data.  */
 +  if (size == 0 || ptr == NULL)
 +    return malloc (size);
 +  block = ((char *) ptr - _heapbase) / BLOCKSIZE + 1;
 +  type = _heapinfo[block].busy.type;
 +  oldsize =
 +    type == 0 ? _heapinfo[block].busy.info.size * BLOCKSIZE
 +    : (size_t) 1 << type;
 +  result = malloc (size);
 +  if (result)
 +    return memcpy (result, ptr, min (oldsize, size));
 +  return result;
 +}
 +
 +#ifdef HYBRID_GET_CURRENT_DIR_NAME
 +/* Defined in sysdep.c.  */
 +char *gget_current_dir_name (void);
 +
 +char *
 +hybrid_get_current_dir_name (void)
 +{
 +  if (DUMPED)
 +    return get_current_dir_name ();
 +  return gget_current_dir_name ();
 +}
 +#endif
 +
 +#endif	/* HYBRID_MALLOC */
 +
 +#ifdef GC_MCHECK
 +
 +/* Standard debugging hooks for `malloc'.
 +   Copyright 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc.
 +   Written May 1989 by Mike Haertel.
 +
 +This library is free software; you can redistribute it and/or
 +modify it under the terms of the GNU General Public License as
 +published by the Free Software Foundation; either version 2 of the
 +License, or (at your option) any later version.
 +
 +This library is distributed in the hope that it will be useful,
 +but WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 +General Public License for more details.
 +
 +You should have received a copy of the GNU General Public
 +License along with this library.  If not, see .
 +
 +   The author may be reached (Email) at the address mike@ai.mit.edu,
 +   or (US mail) as Mike Haertel c/o Free Software Foundation.  */
 +
 +#include 
 +
 +/* Old hook values.  */
 +static void (*old_free_hook) (void *ptr);
 +static void *(*old_malloc_hook) (size_t size);
 +static void *(*old_realloc_hook) (void *ptr, size_t size);
 +
 +/* Function to call when something awful happens.  */
 +static void (*abortfunc) (enum mcheck_status);
 +
 +/* Arbitrary magical numbers.  */
 +#define MAGICWORD	(SIZE_MAX / 11 ^ SIZE_MAX / 13 << 3)
 +#define MAGICFREE	(SIZE_MAX / 17 ^ SIZE_MAX / 19 << 4)
 +#define MAGICBYTE	((char) 0xd7)
 +#define MALLOCFLOOD	((char) 0x93)
 +#define FREEFLOOD	((char) 0x95)
 +
 +struct hdr
 +  {
 +    size_t size;	/* Exact size requested by user.  */
 +    size_t magic;	/* Magic number to check header integrity.  */
 +  };
 +
 +static enum mcheck_status
 +checkhdr (const struct hdr *hdr)
 +{
 +  enum mcheck_status status;
 +  switch (hdr->magic)
 +    {
 +    default:
 +      status = MCHECK_HEAD;
 +      break;
 +    case MAGICFREE:
 +      status = MCHECK_FREE;
 +      break;
 +    case MAGICWORD:
 +      if (((char *) &hdr[1])[hdr->size] != MAGICBYTE)
 +	status = MCHECK_TAIL;
 +      else
 +	status = MCHECK_OK;
 +      break;
 +    }
 +  if (status != MCHECK_OK)
 +    (*abortfunc) (status);
 +  return status;
 +}
 +
 +static void
 +freehook (void *ptr)
 +{
 +  struct hdr *hdr;
 +
 +  if (ptr)
 +    {
 +      struct alignlist *l;
 +
 +      /* If the block was allocated by aligned_alloc, its real pointer
 +	 to free is recorded in _aligned_blocks; find that.  */
 +      PROTECT_MALLOC_STATE (0);
 +      LOCK_ALIGNED_BLOCKS ();
 +      for (l = _aligned_blocks; l != NULL; l = l->next)
 +	if (l->aligned == ptr)
 +	  {
 +	    l->aligned = NULL;	/* Mark the slot in the list as free.  */
 +	    ptr = l->exact;
 +	    break;
 +	  }
 +      UNLOCK_ALIGNED_BLOCKS ();
 +      PROTECT_MALLOC_STATE (1);
 +
 +      hdr = ((struct hdr *) ptr) - 1;
 +      checkhdr (hdr);
 +      hdr->magic = MAGICFREE;
 +      memset (ptr, FREEFLOOD, hdr->size);
 +    }
 +  else
 +    hdr = NULL;
 +
 +  __free_hook = old_free_hook;
 +  free (hdr);
 +  __free_hook = freehook;
 +}
 +
 +static void *
 +mallochook (size_t size)
 +{
 +  struct hdr *hdr;
 +
 +  __malloc_hook = old_malloc_hook;
 +  hdr = malloc (sizeof *hdr + size + 1);
 +  __malloc_hook = mallochook;
 +  if (hdr == NULL)
 +    return NULL;
 +
 +  hdr->size = size;
 +  hdr->magic = MAGICWORD;
 +  ((char *) &hdr[1])[size] = MAGICBYTE;
 +  return memset (hdr + 1, MALLOCFLOOD, size);
 +}
 +
 +static void *
 +reallochook (void *ptr, size_t size)
 +{
 +  struct hdr *hdr = NULL;
 +  size_t osize = 0;
 +
 +  if (ptr)
 +    {
 +      hdr = ((struct hdr *) ptr) - 1;
 +      osize = hdr->size;
 +
 +      checkhdr (hdr);
 +      if (size < osize)
 +	memset ((char *) ptr + size, FREEFLOOD, osize - size);
 +    }
 +
 +  __free_hook = old_free_hook;
 +  __malloc_hook = old_malloc_hook;
 +  __realloc_hook = old_realloc_hook;
 +  hdr = realloc (hdr, sizeof *hdr + size + 1);
 +  __free_hook = freehook;
 +  __malloc_hook = mallochook;
 +  __realloc_hook = reallochook;
 +  if (hdr == NULL)
 +    return NULL;
 +
 +  hdr->size = size;
 +  hdr->magic = MAGICWORD;
 +  ((char *) &hdr[1])[size] = MAGICBYTE;
 +  if (size > osize)
 +    memset ((char *) (hdr + 1) + osize, MALLOCFLOOD, size - osize);
 +  return hdr + 1;
 +}
 +
 +static void
 +mabort (enum mcheck_status status)
 +{
 +  const char *msg;
 +  switch (status)
 +    {
 +    case MCHECK_OK:
 +      msg = "memory is consistent, library is buggy";
 +      break;
 +    case MCHECK_HEAD:
 +      msg = "memory clobbered before allocated block";
 +      break;
 +    case MCHECK_TAIL:
 +      msg = "memory clobbered past end of allocated block";
 +      break;
 +    case MCHECK_FREE:
 +      msg = "block freed twice";
 +      break;
 +    default:
 +      msg = "bogus mcheck_status, library is buggy";
 +      break;
 +    }
 +#ifdef __GNU_LIBRARY__
 +  __libc_fatal (msg);
 +#else
 +  fprintf (stderr, "mcheck: %s\n", msg);
 +  fflush (stderr);
 +# ifdef emacs
 +  emacs_abort ();
 +# else
 +  abort ();
 +# endif
 +#endif
 +}
 +
 +static int mcheck_used = 0;
 +
 +int
 +mcheck (void (*func) (enum mcheck_status))
 +{
 +  abortfunc = (func != NULL) ? func : &mabort;
 +
 +  /* These hooks may not be safely inserted if malloc is already in use.  */
 +  if (!__malloc_initialized && !mcheck_used)
 +    {
 +      old_free_hook = __free_hook;
 +      __free_hook = freehook;
 +      old_malloc_hook = __malloc_hook;
 +      __malloc_hook = mallochook;
 +      old_realloc_hook = __realloc_hook;
 +      __realloc_hook = reallochook;
 +      mcheck_used = 1;
 +    }
 +
 +  return mcheck_used ? 0 : -1;
 +}
 +
 +enum mcheck_status
 +mprobe (void *ptr)
 +{
 +  return mcheck_used ? checkhdr (ptr) : MCHECK_DISABLED;
 +}
 +
 +#endif /* GC_MCHECK */
diff --cc test/manual/etags/c-src/emacs/src/keyboard.c
index 68584ee71fc,00000000000..5a651497d73
mode 100644,000000..100644
--- a/test/manual/etags/c-src/emacs/src/keyboard.c
+++ b/test/manual/etags/c-src/emacs/src/keyboard.c
@@@ -1,11960 -1,0 +1,11960 @@@
 +/* Keyboard and mouse input; editor command loop.
 +
- Copyright (C) 1985-1989, 1993-1997, 1999-2016 Free Software Foundation,
++Copyright (C) 1985-1989, 1993-1997, 1999-2017 Free Software Foundation,
 +Inc.
 +
 +This file is part of GNU Emacs.
 +
 +GNU Emacs is free software: you can redistribute it and/or modify
 +it under the terms of the GNU General Public License as published by
 +the Free Software Foundation, either version 3 of the License, or (at
 +your option) any later version.
 +
 +GNU Emacs is distributed in the hope that it will be useful,
 +but WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +GNU General Public License for more details.
 +
 +You should have received a copy of the GNU General Public License
 +along with GNU Emacs.  If not, see .  */
 +
 +#include 
 +
 +#include "sysstdio.h"
 +#include 
 +
 +#include "lisp.h"
 +#include "termchar.h"
 +#include "termopts.h"
 +#include "frame.h"
 +#include "termhooks.h"
 +#include "macros.h"
 +#include "keyboard.h"
 +#include "window.h"
 +#include "commands.h"
 +#include "character.h"
 +#include "buffer.h"
 +#include "disptab.h"
 +#include "dispextern.h"
 +#include "syntax.h"
 +#include "intervals.h"
 +#include "keymap.h"
 +#include "blockinput.h"
 +#include "puresize.h"
 +#include "systime.h"
 +#include "atimer.h"
 +#include "process.h"
 +#include 
 +
 +#ifdef HAVE_PTHREAD
 +#include 
 +#endif
 +#ifdef MSDOS
 +#include "msdos.h"
 +#include 
 +#else /* not MSDOS */
 +#include 
 +#endif /* not MSDOS */
 +
 +#if defined USABLE_FIONREAD && defined USG5_4
 +# include 
 +#endif
 +
 +#include "syssignal.h"
 +
 +#include 
 +#include 
 +#include 
 +
 +#ifdef HAVE_WINDOW_SYSTEM
 +#include TERM_HEADER
 +#endif /* HAVE_WINDOW_SYSTEM */
 +
 +/* Variables for blockinput.h:  */
 +
 +/* Positive if interrupt input is blocked right now.  */
 +volatile int interrupt_input_blocked;
 +
 +/* True means an input interrupt or alarm signal has arrived.
 +   The QUIT macro checks this.  */
 +volatile bool pending_signals;
 +
 +#define KBD_BUFFER_SIZE 4096
 +
 +KBOARD *initial_kboard;
 +KBOARD *current_kboard;
 +static KBOARD *all_kboards;
 +
 +/* True in the single-kboard state, false in the any-kboard state.  */
 +static bool single_kboard;
 +
 +#define NUM_RECENT_KEYS (300)
 +
 +/* Index for storing next element into recent_keys.  */
 +static int recent_keys_index;
 +
 +/* Total number of elements stored into recent_keys.  */
 +static int total_keys;
 +
 +/* This vector holds the last NUM_RECENT_KEYS keystrokes.  */
 +static Lisp_Object recent_keys;
 +
 +/* Vector holding the key sequence that invoked the current command.
 +   It is reused for each command, and it may be longer than the current
 +   sequence; this_command_key_count indicates how many elements
 +   actually mean something.
 +   It's easier to staticpro a single Lisp_Object than an array.  */
 +Lisp_Object this_command_keys;
 +ptrdiff_t this_command_key_count;
 +
 +/* True after calling Freset_this_command_lengths.
 +   Usually it is false.  */
 +static bool this_command_key_count_reset;
 +
 +/* This vector is used as a buffer to record the events that were actually read
 +   by read_key_sequence.  */
 +static Lisp_Object raw_keybuf;
 +static int raw_keybuf_count;
 +
 +#define GROW_RAW_KEYBUF							\
 + if (raw_keybuf_count == ASIZE (raw_keybuf))				\
 +   raw_keybuf = larger_vector (raw_keybuf, 1, -1)
 +
 +/* Number of elements of this_command_keys
 +   that precede this key sequence.  */
 +static ptrdiff_t this_single_command_key_start;
 +
 +/* Record values of this_command_key_count and echo_length ()
 +   before this command was read.  */
 +static ptrdiff_t before_command_key_count;
 +static ptrdiff_t before_command_echo_length;
 +
 +#ifdef HAVE_STACK_OVERFLOW_HANDLING
 +
 +/* For longjmp to recover from C stack overflow.  */
 +sigjmp_buf return_to_command_loop;
 +
 +/* Message displayed by Vtop_level when recovering from C stack overflow.  */
 +static Lisp_Object recover_top_level_message;
 +
 +#endif /* HAVE_STACK_OVERFLOW_HANDLING */
 +
 +/* Message normally displayed by Vtop_level.  */
 +static Lisp_Object regular_top_level_message;
 +
 +/* For longjmp to where kbd input is being done.  */
 +
 +static sys_jmp_buf getcjmp;
 +
 +/* True while doing kbd input.  */
 +bool waiting_for_input;
 +
 +/* True while displaying for echoing.   Delays C-g throwing.  */
 +
 +static bool echoing;
 +
 +/* Non-null means we can start echoing at the next input pause even
 +   though there is something in the echo area.  */
 +
 +static struct kboard *ok_to_echo_at_next_pause;
 +
 +/* The kboard last echoing, or null for none.  Reset to 0 in
 +   cancel_echoing.  If non-null, and a current echo area message
 +   exists, and echo_message_buffer is eq to the current message
 +   buffer, we know that the message comes from echo_kboard.  */
 +
 +struct kboard *echo_kboard;
 +
 +/* The buffer used for echoing.  Set in echo_now, reset in
 +   cancel_echoing.  */
 +
 +Lisp_Object echo_message_buffer;
 +
 +/* True means C-g should cause immediate error-signal.  */
 +bool immediate_quit;
 +
 +/* Character that causes a quit.  Normally C-g.
 +
 +   If we are running on an ordinary terminal, this must be an ordinary
 +   ASCII char, since we want to make it our interrupt character.
 +
 +   If we are not running on an ordinary terminal, it still needs to be
 +   an ordinary ASCII char.  This character needs to be recognized in
 +   the input interrupt handler.  At this point, the keystroke is
 +   represented as a struct input_event, while the desired quit
 +   character is specified as a lispy event.  The mapping from struct
 +   input_events to lispy events cannot run in an interrupt handler,
 +   and the reverse mapping is difficult for anything but ASCII
 +   keystrokes.
 +
 +   FOR THESE ELABORATE AND UNSATISFYING REASONS, quit_char must be an
 +   ASCII character.  */
 +int quit_char;
 +
 +/* Current depth in recursive edits.  */
 +EMACS_INT command_loop_level;
 +
 +/* If not Qnil, this is a switch-frame event which we decided to put
 +   off until the end of a key sequence.  This should be read as the
 +   next command input, after any unread_command_events.
 +
 +   read_key_sequence uses this to delay switch-frame events until the
 +   end of the key sequence; Fread_char uses it to put off switch-frame
 +   events until a non-ASCII event is acceptable as input.  */
 +Lisp_Object unread_switch_frame;
 +
 +/* Last size recorded for a current buffer which is not a minibuffer.  */
 +static ptrdiff_t last_non_minibuf_size;
 +
 +/* Total number of times read_char has returned, modulo UINTMAX_MAX + 1.  */
 +uintmax_t num_input_events;
 +
 +/* Value of num_nonmacro_input_events as of last auto save.  */
 +
 +static EMACS_INT last_auto_save;
 +
 +/* The value of point when the last command was started.  */
 +static ptrdiff_t last_point_position;
 +
 +/* The frame in which the last input event occurred, or Qmacro if the
 +   last event came from a macro.  We use this to determine when to
 +   generate switch-frame events.  This may be cleared by functions
 +   like Fselect_frame, to make sure that a switch-frame event is
 +   generated by the next character.
 +
 +   FIXME: This is modified by a signal handler so it should be volatile.
 +   It's exported to Lisp, though, so it can't simply be marked
 +   'volatile' here.  */
 +Lisp_Object internal_last_event_frame;
 +
 +/* `read_key_sequence' stores here the command definition of the
 +   key sequence that it reads.  */
 +static Lisp_Object read_key_sequence_cmd;
 +static Lisp_Object read_key_sequence_remapped;
 +
 +/* File in which we write all commands we read.  */
 +static FILE *dribble;
 +
 +/* True if input is available.  */
 +bool input_pending;
 +
 +/* True if more input was available last time we read an event.
 +
 +   Since redisplay can take a significant amount of time and is not
 +   indispensable to perform the user's commands, when input arrives
 +   "too fast", Emacs skips redisplay.  More specifically, if the next
 +   command has already been input when we finish the previous command,
 +   we skip the intermediate redisplay.
 +
 +   This is useful to try and make sure Emacs keeps up with fast input
 +   rates, such as auto-repeating keys.  But in some cases, this proves
 +   too conservative: we may end up disabling redisplay for the whole
 +   duration of a key repetition, even though we could afford to
 +   redisplay every once in a while.
 +
 +   So we "sample" the input_pending flag before running a command and
 +   use *that* value after running the command to decide whether to
 +   skip redisplay or not.  This way, we only skip redisplay if we
 +   really can't keep up with the repeat rate.
 +
 +   This only makes a difference if the next input arrives while running the
 +   command, which is very unlikely if the command is executed quickly.
 +   IOW this tends to avoid skipping redisplay after a long running command
 +   (which is a case where skipping redisplay is not very useful since the
 +   redisplay time is small compared to the time it took to run the command).
 +
 +   A typical use case is when scrolling.  Scrolling time can be split into:
 +   - Time to do jit-lock on the newly displayed portion of buffer.
 +   - Time to run the actual scroll command.
 +   - Time to perform the redisplay.
 +   Jit-lock can happen either during the command or during the redisplay.
 +   In the most painful cases, the jit-lock time is the one that dominates.
 +   Also jit-lock can be tweaked (via jit-lock-defer) to delay its job, at the
 +   cost of temporary inaccuracy in display and scrolling.
 +   So without input_was_pending, what typically happens is the following:
 +   - when the command starts, there's no pending input (yet).
 +   - the scroll command triggers jit-lock.
 +   - during the long jit-lock time the next input arrives.
 +   - at the end of the command, we check input_pending and hence decide to
 +     skip redisplay.
 +   - we read the next input and start over.
 +   End result: all the hard work of jit-locking is "wasted" since redisplay
 +   doesn't actually happens (at least not before the input rate slows down).
 +   With input_was_pending redisplay is still skipped if Emacs can't keep up
 +   with the input rate, but if it can keep up just enough that there's no
 +   input_pending when we begin the command, then redisplay is not skipped
 +   which results in better feedback to the user.  */
 +static bool input_was_pending;
 +
 +/* Circular buffer for pre-read keyboard input.  */
 +
 +static struct input_event kbd_buffer[KBD_BUFFER_SIZE];
 +
 +/* Pointer to next available character in kbd_buffer.
 +   If kbd_fetch_ptr == kbd_store_ptr, the buffer is empty.
 +   This may be kbd_buffer + KBD_BUFFER_SIZE, meaning that the
 +   next available char is in kbd_buffer[0].  */
 +static struct input_event *kbd_fetch_ptr;
 +
 +/* Pointer to next place to store character in kbd_buffer.  This
 +   may be kbd_buffer + KBD_BUFFER_SIZE, meaning that the next
 +   character should go in kbd_buffer[0].  */
 +static struct input_event * volatile kbd_store_ptr;
 +
 +/* The above pair of variables forms a "queue empty" flag.  When we
 +   enqueue a non-hook event, we increment kbd_store_ptr.  When we
 +   dequeue a non-hook event, we increment kbd_fetch_ptr.  We say that
 +   there is input available if the two pointers are not equal.
 +
 +   Why not just have a flag set and cleared by the enqueuing and
 +   dequeuing functions?  Such a flag could be screwed up by interrupts
 +   at inopportune times.  */
 +
 +static void recursive_edit_unwind (Lisp_Object buffer);
 +static Lisp_Object command_loop (void);
 +
 +static void echo_now (void);
 +static ptrdiff_t echo_length (void);
 +
 +/* Incremented whenever a timer is run.  */
 +unsigned timers_run;
 +
 +/* Address (if not 0) of struct timespec to zero out if a SIGIO interrupt
 +   happens.  */
 +struct timespec *input_available_clear_time;
 +
 +/* True means use SIGIO interrupts; false means use CBREAK mode.
 +   Default is true if INTERRUPT_INPUT is defined.  */
 +bool interrupt_input;
 +
 +/* Nonzero while interrupts are temporarily deferred during redisplay.  */
 +bool interrupts_deferred;
 +
 +/* The time when Emacs started being idle.  */
 +
 +static struct timespec timer_idleness_start_time;
 +
 +/* After Emacs stops being idle, this saves the last value
 +   of timer_idleness_start_time from when it was idle.  */
 +
 +static struct timespec timer_last_idleness_start_time;
 +
 +
 +/* Global variable declarations.  */
 +
 +/* Flags for readable_events.  */
 +#define READABLE_EVENTS_DO_TIMERS_NOW		(1 << 0)
 +#define READABLE_EVENTS_FILTER_EVENTS		(1 << 1)
 +#define READABLE_EVENTS_IGNORE_SQUEEZABLES	(1 << 2)
 +
 +/* Function for init_keyboard to call with no args (if nonzero).  */
 +static void (*keyboard_init_hook) (void);
 +
 +static bool get_input_pending (int);
 +static bool readable_events (int);
 +static Lisp_Object read_char_x_menu_prompt (Lisp_Object,
 +                                            Lisp_Object, bool *);
 +static Lisp_Object read_char_minibuf_menu_prompt (int, Lisp_Object);
 +static Lisp_Object make_lispy_event (struct input_event *);
 +static Lisp_Object make_lispy_movement (struct frame *, Lisp_Object,
 +                                        enum scroll_bar_part,
 +                                        Lisp_Object, Lisp_Object,
 +					Time);
 +static Lisp_Object modify_event_symbol (ptrdiff_t, int, Lisp_Object,
 +                                        Lisp_Object, const char *const *,
 +                                        Lisp_Object *, ptrdiff_t);
 +static Lisp_Object make_lispy_switch_frame (Lisp_Object);
 +static Lisp_Object make_lispy_focus_in (Lisp_Object);
 +#ifdef HAVE_WINDOW_SYSTEM
 +static Lisp_Object make_lispy_focus_out (Lisp_Object);
 +#endif /* HAVE_WINDOW_SYSTEM */
 +static bool help_char_p (Lisp_Object);
 +static void save_getcjmp (sys_jmp_buf);
 +static void restore_getcjmp (sys_jmp_buf);
 +static Lisp_Object apply_modifiers (int, Lisp_Object);
 +static void clear_event (struct input_event *);
 +static void restore_kboard_configuration (int);
 +#ifdef USABLE_SIGIO
 +static void deliver_input_available_signal (int signo);
 +#endif
 +static void handle_interrupt (bool);
 +static _Noreturn void quit_throw_to_read_char (bool);
 +static void process_special_events (void);
 +static void timer_start_idle (void);
 +static void timer_stop_idle (void);
 +static void timer_resume_idle (void);
 +static void deliver_user_signal (int);
 +static char *find_user_signal_name (int);
 +static void store_user_signal_events (void);
 +
 +/* These setters are used only in this file, so they can be private.  */
 +static void
 +kset_echo_string (struct kboard *kb, Lisp_Object val)
 +{
 +  kb->echo_string_ = val;
 +}
 +static void
 +kset_kbd_queue (struct kboard *kb, Lisp_Object val)
 +{
 +  kb->kbd_queue_ = val;
 +}
 +static void
 +kset_keyboard_translate_table (struct kboard *kb, Lisp_Object val)
 +{
 +  kb->Vkeyboard_translate_table_ = val;
 +}
 +static void
 +kset_last_prefix_arg (struct kboard *kb, Lisp_Object val)
 +{
 +  kb->Vlast_prefix_arg_ = val;
 +}
 +static void
 +kset_last_repeatable_command (struct kboard *kb, Lisp_Object val)
 +{
 +  kb->Vlast_repeatable_command_ = val;
 +}
 +static void
 +kset_local_function_key_map (struct kboard *kb, Lisp_Object val)
 +{
 +  kb->Vlocal_function_key_map_ = val;
 +}
 +static void
 +kset_overriding_terminal_local_map (struct kboard *kb, Lisp_Object val)
 +{
 +  kb->Voverriding_terminal_local_map_ = val;
 +}
 +static void
 +kset_real_last_command (struct kboard *kb, Lisp_Object val)
 +{
 +  kb->Vreal_last_command_ = val;
 +}
 +static void
 +kset_system_key_syms (struct kboard *kb, Lisp_Object val)
 +{
 +  kb->system_key_syms_ = val;
 +}
 +
 +
 +/* Add C to the echo string, without echoing it immediately.  C can be
 +   a character, which is pretty-printed, or a symbol, whose name is
 +   printed.  */
 +
 +static void
 +echo_add_key (Lisp_Object c)
 +{
 +  char initbuf[KEY_DESCRIPTION_SIZE + 100];
 +  ptrdiff_t size = sizeof initbuf;
 +  char *buffer = initbuf;
 +  char *ptr = buffer;
 +  Lisp_Object echo_string;
 +  USE_SAFE_ALLOCA;
 +
 +  echo_string = KVAR (current_kboard, echo_string);
 +
 +  /* If someone has passed us a composite event, use its head symbol.  */
 +  c = EVENT_HEAD (c);
 +
 +  if (INTEGERP (c))
 +    ptr = push_key_description (XINT (c), ptr);
 +  else if (SYMBOLP (c))
 +    {
 +      Lisp_Object name = SYMBOL_NAME (c);
 +      ptrdiff_t nbytes = SBYTES (name);
 +
 +      if (size - (ptr - buffer) < nbytes)
 +	{
 +	  ptrdiff_t offset = ptr - buffer;
 +	  size = max (2 * size, size + nbytes);
 +	  buffer = SAFE_ALLOCA (size);
 +	  ptr = buffer + offset;
 +	}
 +
 +      ptr += copy_text (SDATA (name), (unsigned char *) ptr, nbytes,
 +			STRING_MULTIBYTE (name), 1);
 +    }
 +
 +  if ((NILP (echo_string) || SCHARS (echo_string) == 0)
 +      && help_char_p (c))
 +    {
 +      static const char text[] = " (Type ? for further options)";
 +      int len = sizeof text - 1;
 +
 +      if (size - (ptr - buffer) < len)
 +	{
 +	  ptrdiff_t offset = ptr - buffer;
 +	  size += len;
 +	  buffer = SAFE_ALLOCA (size);
 +	  ptr = buffer + offset;
 +	}
 +
 +      memcpy (ptr, text, len);
 +      ptr += len;
 +    }
 +
 +  /* Replace a dash from echo_dash with a space, otherwise add a space
 +     at the end as a separator between keys.  */
 +  AUTO_STRING (space, " ");
 +  if (STRINGP (echo_string) && SCHARS (echo_string) > 1)
 +    {
 +      Lisp_Object last_char, prev_char, idx;
 +
 +      idx = make_number (SCHARS (echo_string) - 2);
 +      prev_char = Faref (echo_string, idx);
 +
 +      idx = make_number (SCHARS (echo_string) - 1);
 +      last_char = Faref (echo_string, idx);
 +
 +      /* We test PREV_CHAR to make sure this isn't the echoing of a
 +	 minus-sign.  */
 +      if (XINT (last_char) == '-' && XINT (prev_char) != ' ')
 +	Faset (echo_string, idx, make_number (' '));
 +      else
 +	echo_string = concat2 (echo_string, space);
 +    }
 +  else if (STRINGP (echo_string) && SCHARS (echo_string) > 0)
 +    echo_string = concat2 (echo_string, space);
 +
 +  kset_echo_string
 +    (current_kboard,
 +     concat2 (echo_string, make_string (buffer, ptr - buffer)));
 +  SAFE_FREE ();
 +}
 +
 +/* Add C to the echo string, if echoing is going on.  C can be a
 +   character or a symbol.  */
 +
 +static void
 +echo_char (Lisp_Object c)
 +{
 +  if (current_kboard->immediate_echo)
 +    {
 +      echo_add_key (c);
 +      echo_now ();
 +    }
 +}
 +
 +/* Temporarily add a dash to the end of the echo string if it's not
 +   empty, so that it serves as a mini-prompt for the very next
 +   character.  */
 +
 +static void
 +echo_dash (void)
 +{
 +  /* Do nothing if not echoing at all.  */
 +  if (NILP (KVAR (current_kboard, echo_string)))
 +    return;
 +
 +  if (this_command_key_count == 0)
 +    return;
 +
 +  if (!current_kboard->immediate_echo
 +      && SCHARS (KVAR (current_kboard, echo_string)) == 0)
 +    return;
 +
 +  /* Do nothing if we just printed a prompt.  */
 +  if (current_kboard->echo_after_prompt
 +      == SCHARS (KVAR (current_kboard, echo_string)))
 +    return;
 +
 +  /* Do nothing if we have already put a dash at the end.  */
 +  if (SCHARS (KVAR (current_kboard, echo_string)) > 1)
 +    {
 +      Lisp_Object last_char, prev_char, idx;
 +
 +      idx = make_number (SCHARS (KVAR (current_kboard, echo_string)) - 2);
 +      prev_char = Faref (KVAR (current_kboard, echo_string), idx);
 +
 +      idx = make_number (SCHARS (KVAR (current_kboard, echo_string)) - 1);
 +      last_char = Faref (KVAR (current_kboard, echo_string), idx);
 +
 +      if (XINT (last_char) == '-' && XINT (prev_char) != ' ')
 +	return;
 +    }
 +
 +  /* Put a dash at the end of the buffer temporarily,
 +     but make it go away when the next character is added.  */
 +  AUTO_STRING (dash, "-");
 +  kset_echo_string (current_kboard,
 +		    concat2 (KVAR (current_kboard, echo_string), dash));
 +  echo_now ();
 +}
 +
 +/* Display the current echo string, and begin echoing if not already
 +   doing so.  */
 +
 +static void
 +echo_now (void)
 +{
 +  if (!current_kboard->immediate_echo)
 +    {
 +      ptrdiff_t i;
 +      current_kboard->immediate_echo = 1;
 +
 +      for (i = 0; i < this_command_key_count; i++)
 +	{
 +	  Lisp_Object c;
 +
 +	  /* Set before_command_echo_length to the value that would
 +	     have been saved before the start of this subcommand in
 +	     command_loop_1, if we had already been echoing then.  */
 +	  if (i == this_single_command_key_start)
 +	    before_command_echo_length = echo_length ();
 +
 +	  c = AREF (this_command_keys, i);
 +	  if (! (EVENT_HAS_PARAMETERS (c)
 +		 && EQ (EVENT_HEAD_KIND (EVENT_HEAD (c)), Qmouse_movement)))
 +	    echo_char (c);
 +	}
 +
 +      /* Set before_command_echo_length to the value that would
 +	 have been saved before the start of this subcommand in
 +	 command_loop_1, if we had already been echoing then.  */
 +      if (this_command_key_count == this_single_command_key_start)
 +	before_command_echo_length = echo_length ();
 +
 +      /* Put a dash at the end to invite the user to type more.  */
 +      echo_dash ();
 +    }
 +
 +  echoing = 1;
 +  /* FIXME: Use call (Qmessage) so it can be advised (e.g. emacspeak).  */
 +  message3_nolog (KVAR (current_kboard, echo_string));
 +  echoing = 0;
 +
 +  /* Record in what buffer we echoed, and from which kboard.  */
 +  echo_message_buffer = echo_area_buffer[0];
 +  echo_kboard = current_kboard;
 +
 +  if (waiting_for_input && !NILP (Vquit_flag))
 +    quit_throw_to_read_char (0);
 +}
 +
 +/* Turn off echoing, for the start of a new command.  */
 +
 +void
 +cancel_echoing (void)
 +{
 +  current_kboard->immediate_echo = 0;
 +  current_kboard->echo_after_prompt = -1;
 +  kset_echo_string (current_kboard, Qnil);
 +  ok_to_echo_at_next_pause = NULL;
 +  echo_kboard = NULL;
 +  echo_message_buffer = Qnil;
 +}
 +
 +/* Return the length of the current echo string.  */
 +
 +static ptrdiff_t
 +echo_length (void)
 +{
 +  return (STRINGP (KVAR (current_kboard, echo_string))
 +	  ? SCHARS (KVAR (current_kboard, echo_string))
 +	  : 0);
 +}
 +
 +/* Truncate the current echo message to its first LEN chars.
 +   This and echo_char get used by read_key_sequence when the user
 +   switches frames while entering a key sequence.  */
 +
 +static void
 +echo_truncate (ptrdiff_t nchars)
 +{
 +  if (STRINGP (KVAR (current_kboard, echo_string)))
 +    kset_echo_string (current_kboard,
 +		      Fsubstring (KVAR (current_kboard, echo_string),
 +				  make_number (0), make_number (nchars)));
 +  truncate_echo_area (nchars);
 +}
 +
 +
 +/* Functions for manipulating this_command_keys.  */
 +static void
 +add_command_key (Lisp_Object key)
 +{
 +#if 0 /* Not needed after we made Freset_this_command_lengths
 +	 do the job immediately.  */
 +  /* If reset-this-command-length was called recently, obey it now.
 +     See the doc string of that function for an explanation of why.  */
 +  if (before_command_restore_flag)
 +    {
 +      this_command_key_count = before_command_key_count_1;
 +      if (this_command_key_count < this_single_command_key_start)
 +	this_single_command_key_start = this_command_key_count;
 +      echo_truncate (before_command_echo_length_1);
 +      before_command_restore_flag = 0;
 +    }
 +#endif
 +
 +  if (this_command_key_count >= ASIZE (this_command_keys))
 +    this_command_keys = larger_vector (this_command_keys, 1, -1);
 +
 +  ASET (this_command_keys, this_command_key_count, key);
 +  ++this_command_key_count;
 +}
 +
 +
 +Lisp_Object
 +recursive_edit_1 (void)
 +{
 +  ptrdiff_t count = SPECPDL_INDEX ();
 +  Lisp_Object val;
 +
 +  if (command_loop_level > 0)
 +    {
 +      specbind (Qstandard_output, Qt);
 +      specbind (Qstandard_input, Qt);
 +    }
 +
 +#ifdef HAVE_WINDOW_SYSTEM
 +  /* The command loop has started an hourglass timer, so we have to
 +     cancel it here, otherwise it will fire because the recursive edit
 +     can take some time.  Do not check for display_hourglass_p here,
 +     because it could already be nil.  */
 +    cancel_hourglass ();
 +#endif
 +
 +  /* This function may have been called from a debugger called from
 +     within redisplay, for instance by Edebugging a function called
 +     from fontification-functions.  We want to allow redisplay in
 +     the debugging session.
 +
 +     The recursive edit is left with a `(throw exit ...)'.  The `exit'
 +     tag is not caught anywhere in redisplay, i.e. when we leave the
 +     recursive edit, the original redisplay leading to the recursive
 +     edit will be unwound.  The outcome should therefore be safe.  */
 +  specbind (Qinhibit_redisplay, Qnil);
 +  redisplaying_p = 0;
 +
 +  val = command_loop ();
 +  if (EQ (val, Qt))
 +    Fsignal (Qquit, Qnil);
 +  /* Handle throw from read_minibuf when using minibuffer
 +     while it's active but we're in another window.  */
 +  if (STRINGP (val))
 +    xsignal1 (Qerror, val);
 +
 +  return unbind_to (count, Qnil);
 +}
 +
 +/* When an auto-save happens, record the "time", and don't do again soon.  */
 +
 +void
 +record_auto_save (void)
 +{
 +  last_auto_save = num_nonmacro_input_events;
 +}
 +
 +/* Make an auto save happen as soon as possible at command level.  */
 +
 +#ifdef SIGDANGER
 +void
 +force_auto_save_soon (void)
 +{
 +  last_auto_save = - auto_save_interval - 1;
 +
 +  record_asynch_buffer_change ();
 +}
 +#endif
 +
 +DEFUN ("recursive-edit", Frecursive_edit, Srecursive_edit, 0, 0, "",
 +       doc: /* Invoke the editor command loop recursively.
 +To get out of the recursive edit, a command can throw to `exit' -- for
 +instance `(throw 'exit nil)'.
 +If you throw a value other than t, `recursive-edit' returns normally
 +to the function that called it.  Throwing a t value causes
 +`recursive-edit' to quit, so that control returns to the command loop
 +one level up.
 +
 +This function is called by the editor initialization to begin editing.  */)
 +  (void)
 +{
 +  ptrdiff_t count = SPECPDL_INDEX ();
 +  Lisp_Object buffer;
 +
 +  /* If we enter while input is blocked, don't lock up here.
 +     This may happen through the debugger during redisplay.  */
 +  if (input_blocked_p ())
 +    return Qnil;
 +
 +  if (command_loop_level >= 0
 +      && current_buffer != XBUFFER (XWINDOW (selected_window)->contents))
 +    buffer = Fcurrent_buffer ();
 +  else
 +    buffer = Qnil;
 +
 +  /* Don't do anything interesting between the increment and the
 +     record_unwind_protect!  Otherwise, we could get distracted and
 +     never decrement the counter again.  */
 +  command_loop_level++;
 +  update_mode_lines = 17;
 +  record_unwind_protect (recursive_edit_unwind, buffer);
 +
 +  /* If we leave recursive_edit_1 below with a `throw' for instance,
 +     like it is done in the splash screen display, we have to
 +     make sure that we restore single_kboard as command_loop_1
 +     would have done if it were left normally.  */
 +  if (command_loop_level > 0)
 +    temporarily_switch_to_single_kboard (SELECTED_FRAME ());
 +
 +  recursive_edit_1 ();
 +  return unbind_to (count, Qnil);
 +}
 +
 +void
 +recursive_edit_unwind (Lisp_Object buffer)
 +{
 +  if (BUFFERP (buffer))
 +    Fset_buffer (buffer);
 +
 +  command_loop_level--;
 +  update_mode_lines = 18;
 +}
 +
 +
 +#if 0  /* These two functions are now replaced with
 +          temporarily_switch_to_single_kboard.  */
 +static void
 +any_kboard_state ()
 +{
 +#if 0 /* Theory: if there's anything in Vunread_command_events,
 +	 it will right away be read by read_key_sequence,
 +	 and then if we do switch KBOARDS, it will go into the side
 +	 queue then.  So we don't need to do anything special here -- rms.  */
 +  if (CONSP (Vunread_command_events))
 +    {
 +      current_kboard->kbd_queue
 +	= nconc2 (Vunread_command_events, current_kboard->kbd_queue);
 +      current_kboard->kbd_queue_has_data = 1;
 +    }
 +  Vunread_command_events = Qnil;
 +#endif
 +  single_kboard = 0;
 +}
 +
 +/* Switch to the single-kboard state, making current_kboard
 +   the only KBOARD from which further input is accepted.  */
 +
 +void
 +single_kboard_state ()
 +{
 +  single_kboard = 1;
 +}
 +#endif
 +
 +/* If we're in single_kboard state for kboard KBOARD,
 +   get out of it.  */
 +
 +void
 +not_single_kboard_state (KBOARD *kboard)
 +{
 +  if (kboard == current_kboard)
 +    single_kboard = 0;
 +}
 +
 +/* Maintain a stack of kboards, so other parts of Emacs
 +   can switch temporarily to the kboard of a given frame
 +   and then revert to the previous status.  */
 +
 +struct kboard_stack
 +{
 +  KBOARD *kboard;
 +  struct kboard_stack *next;
 +};
 +
 +static struct kboard_stack *kboard_stack;
 +
 +void
 +push_kboard (struct kboard *k)
 +{
 +  struct kboard_stack *p = xmalloc (sizeof *p);
 +
 +  p->next = kboard_stack;
 +  p->kboard = current_kboard;
 +  kboard_stack = p;
 +
 +  current_kboard = k;
 +}
 +
 +void
 +pop_kboard (void)
 +{
 +  struct terminal *t;
 +  struct kboard_stack *p = kboard_stack;
 +  bool found = 0;
 +  for (t = terminal_list; t; t = t->next_terminal)
 +    {
 +      if (t->kboard == p->kboard)
 +        {
 +          current_kboard = p->kboard;
 +          found = 1;
 +          break;
 +        }
 +    }
 +  if (!found)
 +    {
 +      /* The terminal we remembered has been deleted.  */
 +      current_kboard = FRAME_KBOARD (SELECTED_FRAME ());
 +      single_kboard = 0;
 +    }
 +  kboard_stack = p->next;
 +  xfree (p);
 +}
 +
 +/* Switch to single_kboard mode, making current_kboard the only KBOARD
 +  from which further input is accepted.  If F is non-nil, set its
 +  KBOARD as the current keyboard.
 +
 +  This function uses record_unwind_protect_int to return to the previous
 +  state later.
 +
 +  If Emacs is already in single_kboard mode, and F's keyboard is
 +  locked, then this function will throw an error.  */
 +
 +void
 +temporarily_switch_to_single_kboard (struct frame *f)
 +{
 +  bool was_locked = single_kboard;
 +  if (was_locked)
 +    {
 +      if (f != NULL && FRAME_KBOARD (f) != current_kboard)
 +        /* We can not switch keyboards while in single_kboard mode.
 +           In rare cases, Lisp code may call `recursive-edit' (or
 +           `read-minibuffer' or `y-or-n-p') after it switched to a
 +           locked frame.  For example, this is likely to happen
 +           when server.el connects to a new terminal while Emacs is in
 +           single_kboard mode.  It is best to throw an error instead
 +           of presenting the user with a frozen screen.  */
 +        error ("Terminal %d is locked, cannot read from it",
 +               FRAME_TERMINAL (f)->id);
 +      else
 +        /* This call is unnecessary, but helps
 +           `restore_kboard_configuration' discover if somebody changed
 +           `current_kboard' behind our back.  */
 +        push_kboard (current_kboard);
 +    }
 +  else if (f != NULL)
 +    current_kboard = FRAME_KBOARD (f);
 +  single_kboard = 1;
 +  record_unwind_protect_int (restore_kboard_configuration, was_locked);
 +}
 +
 +#if 0 /* This function is not needed anymore.  */
 +void
 +record_single_kboard_state ()
 +{
 +  if (single_kboard)
 +    push_kboard (current_kboard);
 +  record_unwind_protect_int (restore_kboard_configuration, single_kboard);
 +}
 +#endif
 +
 +static void
 +restore_kboard_configuration (int was_locked)
 +{
 +  single_kboard = was_locked;
 +  if (was_locked)
 +    {
 +      struct kboard *prev = current_kboard;
 +      pop_kboard ();
 +      /* The pop should not change the kboard.  */
 +      if (single_kboard && current_kboard != prev)
 +        emacs_abort ();
 +    }
 +}
 +
 +
 +/* Handle errors that are not handled at inner levels
 +   by printing an error message and returning to the editor command loop.  */
 +
 +static Lisp_Object
 +cmd_error (Lisp_Object data)
 +{
 +  Lisp_Object old_level, old_length;
 +  char macroerror[sizeof "After..kbd macro iterations: "
 +		  + INT_STRLEN_BOUND (EMACS_INT)];
 +
 +#ifdef HAVE_WINDOW_SYSTEM
 +  if (display_hourglass_p)
 +    cancel_hourglass ();
 +#endif
 +
 +  if (!NILP (executing_kbd_macro))
 +    {
 +      if (executing_kbd_macro_iterations == 1)
 +	sprintf (macroerror, "After 1 kbd macro iteration: ");
 +      else
 +	sprintf (macroerror, "After %"pI"d kbd macro iterations: ",
 +		 executing_kbd_macro_iterations);
 +    }
 +  else
 +    *macroerror = 0;
 +
 +  Vstandard_output = Qt;
 +  Vstandard_input = Qt;
 +  Vexecuting_kbd_macro = Qnil;
 +  executing_kbd_macro = Qnil;
 +  kset_prefix_arg (current_kboard, Qnil);
 +  kset_last_prefix_arg (current_kboard, Qnil);
 +  cancel_echoing ();
 +
 +  /* Avoid unquittable loop if data contains a circular list.  */
 +  old_level = Vprint_level;
 +  old_length = Vprint_length;
 +  XSETFASTINT (Vprint_level, 10);
 +  XSETFASTINT (Vprint_length, 10);
 +  cmd_error_internal (data, macroerror);
 +  Vprint_level = old_level;
 +  Vprint_length = old_length;
 +
 +  Vquit_flag = Qnil;
 +  Vinhibit_quit = Qnil;
 +
 +  return make_number (0);
 +}
 +
 +/* Take actions on handling an error.  DATA is the data that describes
 +   the error.
 +
 +   CONTEXT is a C-string containing ASCII characters only which
 +   describes the context in which the error happened.  If we need to
 +   generalize CONTEXT to allow multibyte characters, make it a Lisp
 +   string.  */
 +
 +void
 +cmd_error_internal (Lisp_Object data, const char *context)
 +{
 +  /* The immediate context is not interesting for Quits,
 +     since they are asynchronous.  */
 +  if (EQ (XCAR (data), Qquit))
 +    Vsignaling_function = Qnil;
 +
 +  Vquit_flag = Qnil;
 +  Vinhibit_quit = Qt;
 +
 +  /* Use user's specified output function if any.  */
 +  if (!NILP (Vcommand_error_function))
 +    call3 (Vcommand_error_function, data,
 +	   context ? build_string (context) : empty_unibyte_string,
 +	   Vsignaling_function);
 +
 +  Vsignaling_function = Qnil;
 +}
 +
 +DEFUN ("command-error-default-function", Fcommand_error_default_function,
 +       Scommand_error_default_function, 3, 3, 0,
 +       doc: /* Produce default output for unhandled error message.
 +Default value of `command-error-function'.  */)
 +  (Lisp_Object data, Lisp_Object context, Lisp_Object signal)
 +{
 +  struct frame *sf = SELECTED_FRAME ();
 +
 +  CHECK_STRING (context);
 +
 +  /* If the window system or terminal frame hasn't been initialized
 +     yet, or we're not interactive, write the message to stderr and exit.  */
 +  if (!sf->glyphs_initialized_p
 +	   /* The initial frame is a special non-displaying frame. It
 +	      will be current in daemon mode when there are no frames
 +	      to display, and in non-daemon mode before the real frame
 +	      has finished initializing.  If an error is thrown in the
 +	      latter case while creating the frame, then the frame
 +	      will never be displayed, so the safest thing to do is
 +	      write to stderr and quit.  In daemon mode, there are
 +	      many other potential errors that do not prevent frames
 +	      from being created, so continuing as normal is better in
 +	      that case.  */
 +	   || (!IS_DAEMON && FRAME_INITIAL_P (sf))
 +	   || noninteractive)
 +    {
 +      print_error_message (data, Qexternal_debugging_output,
 +			   SSDATA (context), signal);
 +      Fterpri (Qexternal_debugging_output, Qnil);
 +      Fkill_emacs (make_number (-1));
 +    }
 +  else
 +    {
 +      clear_message (1, 0);
 +      Fdiscard_input ();
 +      message_log_maybe_newline ();
 +      bitch_at_user ();
 +
 +      print_error_message (data, Qt, SSDATA (context), signal);
 +    }
 +  return Qnil;
 +}
 +
 +static Lisp_Object command_loop_2 (Lisp_Object);
 +static Lisp_Object top_level_1 (Lisp_Object);
 +
 +/* Entry to editor-command-loop.
 +   This level has the catches for exiting/returning to editor command loop.
 +   It returns nil to exit recursive edit, t to abort it.  */
 +
 +Lisp_Object
 +command_loop (void)
 +{
 +#ifdef HAVE_STACK_OVERFLOW_HANDLING
 +  /* At least on GNU/Linux, saving signal mask is important here.  */
 +  if (sigsetjmp (return_to_command_loop, 1) != 0)
 +    {
 +      /* Comes here from handle_sigsegv, see sysdep.c.  */
 +      init_eval ();
 +      Vinternal__top_level_message = recover_top_level_message;
 +    }
 +  else
 +    Vinternal__top_level_message = regular_top_level_message;
 +#endif /* HAVE_STACK_OVERFLOW_HANDLING */
 +  if (command_loop_level > 0 || minibuf_level > 0)
 +    {
 +      Lisp_Object val;
 +      val = internal_catch (Qexit, command_loop_2, Qnil);
 +      executing_kbd_macro = Qnil;
 +      return val;
 +    }
 +  else
 +    while (1)
 +      {
 +	internal_catch (Qtop_level, top_level_1, Qnil);
 +	internal_catch (Qtop_level, command_loop_2, Qnil);
 +	executing_kbd_macro = Qnil;
 +
 +	/* End of file in -batch run causes exit here.  */
 +	if (noninteractive)
 +	  Fkill_emacs (Qt);
 +      }
 +}
 +
 +/* Here we catch errors in execution of commands within the
 +   editing loop, and reenter the editing loop.
 +   When there is an error, cmd_error runs and returns a non-nil
 +   value to us.  A value of nil means that command_loop_1 itself
 +   returned due to end of file (or end of kbd macro).  */
 +
 +static Lisp_Object
 +command_loop_2 (Lisp_Object ignore)
 +{
 +  register Lisp_Object val;
 +
 +  do
 +    val = internal_condition_case (command_loop_1, Qerror, cmd_error);
 +  while (!NILP (val));
 +
 +  return Qnil;
 +}
 +
 +static Lisp_Object
 +top_level_2 (void)
 +{
 +  return Feval (Vtop_level, Qnil);
 +}
 +
 +static Lisp_Object
 +top_level_1 (Lisp_Object ignore)
 +{
 +  /* On entry to the outer level, run the startup file.  */
 +  if (!NILP (Vtop_level))
 +    internal_condition_case (top_level_2, Qerror, cmd_error);
 +  else if (!NILP (Vpurify_flag))
 +    message1 ("Bare impure Emacs (standard Lisp code not loaded)");
 +  else
 +    message1 ("Bare Emacs (standard Lisp code not loaded)");
 +  return Qnil;
 +}
 +
 +DEFUN ("top-level", Ftop_level, Stop_level, 0, 0, "",
 +       doc: /* Exit all recursive editing levels.
 +This also exits all active minibuffers.  */
 +       attributes: noreturn)
 +  (void)
 +{
 +#ifdef HAVE_WINDOW_SYSTEM
 +  if (display_hourglass_p)
 +    cancel_hourglass ();
 +#endif
 +
 +  /* Unblock input if we enter with input blocked.  This may happen if
 +     redisplay traps e.g. during tool-bar update with input blocked.  */
 +  totally_unblock_input ();
 +
 +  Fthrow (Qtop_level, Qnil);
 +}
 +
 +static _Noreturn void
 +user_error (const char *msg)
 +{
 +  xsignal1 (Quser_error, build_string (msg));
 +}
 +
 +/* _Noreturn will be added to prototype by make-docfile.  */
 +DEFUN ("exit-recursive-edit", Fexit_recursive_edit, Sexit_recursive_edit, 0, 0, "",
 +       doc: /* Exit from the innermost recursive edit or minibuffer.  */
 +       attributes: noreturn)
 +  (void)
 +{
 +  if (command_loop_level > 0 || minibuf_level > 0)
 +    Fthrow (Qexit, Qnil);
 +
 +  user_error ("No recursive edit is in progress");
 +}
 +
 +/* _Noreturn will be added to prototype by make-docfile.  */
 +DEFUN ("abort-recursive-edit", Fabort_recursive_edit, Sabort_recursive_edit, 0, 0, "",
 +       doc: /* Abort the command that requested this recursive edit or minibuffer input.  */
 +       attributes: noreturn)
 +  (void)
 +{
 +  if (command_loop_level > 0 || minibuf_level > 0)
 +    Fthrow (Qexit, Qt);
 +
 +  user_error ("No recursive edit is in progress");
 +}
 +
 +/* Restore mouse tracking enablement.  See Ftrack_mouse for the only use
 +   of this function.  */
 +
 +static void
 +tracking_off (Lisp_Object old_value)
 +{
 +  do_mouse_tracking = old_value;
 +  if (NILP (old_value))
 +    {
 +      /* Redisplay may have been preempted because there was input
 +	 available, and it assumes it will be called again after the
 +	 input has been processed.  If the only input available was
 +	 the sort that we have just disabled, then we need to call
 +	 redisplay.  */
 +      if (!readable_events (READABLE_EVENTS_DO_TIMERS_NOW))
 +	{
 +	  redisplay_preserve_echo_area (6);
 +	  get_input_pending (READABLE_EVENTS_DO_TIMERS_NOW);
 +	}
 +    }
 +}
 +
 +DEFUN ("internal--track-mouse", Ftrack_mouse, Strack_mouse, 1, 1, 0,
 +       doc: /* Call BODYFUN with mouse movement events enabled.  */)
 +  (Lisp_Object bodyfun)
 +{
 +  ptrdiff_t count = SPECPDL_INDEX ();
 +  Lisp_Object val;
 +
 +  record_unwind_protect (tracking_off, do_mouse_tracking);
 +
 +  do_mouse_tracking = Qt;
 +
 +  val = call0 (bodyfun);
 +  return unbind_to (count, val);
 +}
 +
 +/* If mouse has moved on some frame, return one of those frames.
 +
 +   Return 0 otherwise.
 +
 +   If ignore_mouse_drag_p is non-zero, ignore (implicit) mouse movement
 +   after resizing the tool-bar window.  */
 +
 +bool ignore_mouse_drag_p;
 +
 +static struct frame *
 +some_mouse_moved (void)
 +{
 +  Lisp_Object tail, frame;
 +
 +  if (ignore_mouse_drag_p)
 +    {
 +      /* ignore_mouse_drag_p = 0; */
 +      return 0;
 +    }
 +
 +  FOR_EACH_FRAME (tail, frame)
 +    {
 +      if (XFRAME (frame)->mouse_moved)
 +	return XFRAME (frame);
 +    }
 +
 +  return 0;
 +}
 +
 +
 +/* This is the actual command reading loop,
 +   sans error-handling encapsulation.  */
 +
 +static int read_key_sequence (Lisp_Object *, int, Lisp_Object,
 +                              bool, bool, bool, bool);
 +static void adjust_point_for_property (ptrdiff_t, bool);
 +
 +/* The last boundary auto-added to buffer-undo-list.  */
 +Lisp_Object last_undo_boundary;
 +
 +/* FIXME: This is wrong rather than test window-system, we should call
 +   a new set-selection, which will then dispatch to x-set-selection, or
 +   tty-set-selection, or w32-set-selection, ...  */
 +
 +Lisp_Object
 +command_loop_1 (void)
 +{
 +  Lisp_Object cmd;
 +  Lisp_Object keybuf[30];
 +  int i;
 +  EMACS_INT prev_modiff = 0;
 +  struct buffer *prev_buffer = NULL;
 +  bool already_adjusted = 0;
 +
 +  kset_prefix_arg (current_kboard, Qnil);
 +  kset_last_prefix_arg (current_kboard, Qnil);
 +  Vdeactivate_mark = Qnil;
 +  waiting_for_input = 0;
 +  cancel_echoing ();
 +
 +  this_command_key_count = 0;
 +  this_command_key_count_reset = 0;
 +  this_single_command_key_start = 0;
 +
 +  if (NILP (Vmemory_full))
 +    {
 +      /* Make sure this hook runs after commands that get errors and
 +	 throw to top level.  */
 +      /* Note that the value cell will never directly contain nil
 +	 if the symbol is a local variable.  */
 +      if (!NILP (Vpost_command_hook) && !NILP (Vrun_hooks))
 +	safe_run_hooks (Qpost_command_hook);
 +
 +      /* If displaying a message, resize the echo area window to fit
 +	 that message's size exactly.  */
 +      if (!NILP (echo_area_buffer[0]))
 +	resize_echo_area_exactly ();
 +
 +      /* If there are warnings waiting, process them.  */
 +      if (!NILP (Vdelayed_warnings_list))
 +        safe_run_hooks (Qdelayed_warnings_hook);
 +
 +      if (!NILP (Vdeferred_action_list))
 +	safe_run_hooks (Qdeferred_action_function);
 +    }
 +
 +  /* Do this after running Vpost_command_hook, for consistency.  */
 +  kset_last_command (current_kboard, Vthis_command);
 +  kset_real_last_command (current_kboard, Vreal_this_command);
 +  if (!CONSP (last_command_event))
 +    kset_last_repeatable_command (current_kboard, Vreal_this_command);
 +
 +  while (1)
 +    {
 +      if (! FRAME_LIVE_P (XFRAME (selected_frame)))
 +	Fkill_emacs (Qnil);
 +
 +      /* Make sure the current window's buffer is selected.  */
 +      set_buffer_internal (XBUFFER (XWINDOW (selected_window)->contents));
 +
 +      /* Display any malloc warning that just came out.  Use while because
 +	 displaying one warning can cause another.  */
 +
 +      while (pending_malloc_warning)
 +	display_malloc_warning ();
 +
 +      Vdeactivate_mark = Qnil;
 +
 +      /* Don't ignore mouse movements for more than a single command
 +	 loop.  (This flag is set in xdisp.c whenever the tool bar is
 +	 resized, because the resize moves text up or down, and would
 +	 generate false mouse drag events if we don't ignore them.)  */
 +      ignore_mouse_drag_p = 0;
 +
 +      /* If minibuffer on and echo area in use,
 +	 wait a short time and redraw minibuffer.  */
 +
 +      if (minibuf_level
 +	  && !NILP (echo_area_buffer[0])
 +	  && EQ (minibuf_window, echo_area_window)
 +	  && NUMBERP (Vminibuffer_message_timeout))
 +	{
 +	  /* Bind inhibit-quit to t so that C-g gets read in
 +	     rather than quitting back to the minibuffer.  */
 +	  ptrdiff_t count = SPECPDL_INDEX ();
 +	  specbind (Qinhibit_quit, Qt);
 +
 +	  sit_for (Vminibuffer_message_timeout, 0, 2);
 +
 +	  /* Clear the echo area.  */
 +	  message1 (0);
 +	  safe_run_hooks (Qecho_area_clear_hook);
 +
 +	  unbind_to (count, Qnil);
 +
 +	  /* If a C-g came in before, treat it as input now.  */
 +	  if (!NILP (Vquit_flag))
 +	    {
 +	      Vquit_flag = Qnil;
 +	      Vunread_command_events = list1 (make_number (quit_char));
 +	    }
 +	}
 +
 +      /* If it has changed current-menubar from previous value,
 +	 really recompute the menubar from the value.  */
 +      if (! NILP (Vlucid_menu_bar_dirty_flag)
 +	  && !NILP (Ffboundp (Qrecompute_lucid_menubar)))
 +	call0 (Qrecompute_lucid_menubar);
 +
 +      before_command_key_count = this_command_key_count;
 +      before_command_echo_length = echo_length ();
 +
 +      Vthis_command = Qnil;
 +      Vreal_this_command = Qnil;
 +      Vthis_original_command = Qnil;
 +      Vthis_command_keys_shift_translated = Qnil;
 +
 +      /* Read next key sequence; i gets its length.  */
 +      i = read_key_sequence (keybuf, ARRAYELTS (keybuf),
 +			     Qnil, 0, 1, 1, 0);
 +
 +      /* A filter may have run while we were reading the input.  */
 +      if (! FRAME_LIVE_P (XFRAME (selected_frame)))
 +	Fkill_emacs (Qnil);
 +      set_buffer_internal (XBUFFER (XWINDOW (selected_window)->contents));
 +
 +      ++num_input_keys;
 +
 +      /* Now we have read a key sequence of length I,
 +	 or else I is 0 and we found end of file.  */
 +
 +      if (i == 0)		/* End of file -- happens only in */
 +	return Qnil;		/* a kbd macro, at the end.  */
 +      /* -1 means read_key_sequence got a menu that was rejected.
 +	 Just loop around and read another command.  */
 +      if (i == -1)
 +	{
 +	  cancel_echoing ();
 +	  this_command_key_count = 0;
 +	  this_command_key_count_reset = 0;
 +	  this_single_command_key_start = 0;
 +	  goto finalize;
 +	}
 +
 +      last_command_event = keybuf[i - 1];
 +
 +      /* If the previous command tried to force a specific window-start,
 +	 forget about that, in case this command moves point far away
 +	 from that position.  But also throw away beg_unchanged and
 +	 end_unchanged information in that case, so that redisplay will
 +	 update the whole window properly.  */
 +      if (XWINDOW (selected_window)->force_start)
 +	{
 +	  struct buffer *b;
 +	  XWINDOW (selected_window)->force_start = 0;
 +	  b = XBUFFER (XWINDOW (selected_window)->contents);
 +	  BUF_BEG_UNCHANGED (b) = BUF_END_UNCHANGED (b) = 0;
 +	}
 +
 +      cmd = read_key_sequence_cmd;
 +      if (!NILP (Vexecuting_kbd_macro))
 +	{
 +	  if (!NILP (Vquit_flag))
 +	    {
 +	      Vexecuting_kbd_macro = Qt;
 +	      QUIT;		/* Make some noise.  */
 +				/* Will return since macro now empty.  */
 +	    }
 +	}
 +
 +      /* Do redisplay processing after this command except in special
 +	 cases identified below.  */
 +      prev_buffer = current_buffer;
 +      prev_modiff = MODIFF;
 +      last_point_position = PT;
 +
 +      /* By default, we adjust point to a boundary of a region that
 +         has such a property that should be treated intangible
 +         (e.g. composition, display).  But, some commands will set
 +         this variable differently.  */
 +      Vdisable_point_adjustment = Qnil;
 +
 +      /* Process filters and timers may have messed with deactivate-mark.
 +	 reset it before we execute the command.  */
 +      Vdeactivate_mark = Qnil;
 +
 +      /* Remap command through active keymaps.  */
 +      Vthis_original_command = cmd;
 +      if (!NILP (read_key_sequence_remapped))
 +	cmd = read_key_sequence_remapped;
 +
 +      /* Execute the command.  */
 +
 +      {
 +	total_keys += total_keys < NUM_RECENT_KEYS;
 +	ASET (recent_keys, recent_keys_index,
 +	      Fcons (Qnil, cmd));
 +	if (++recent_keys_index >= NUM_RECENT_KEYS)
 +	  recent_keys_index = 0;
 +      }
 +      Vthis_command = cmd;
 +      Vreal_this_command = cmd;
 +      safe_run_hooks (Qpre_command_hook);
 +
 +      already_adjusted = 0;
 +
 +      if (NILP (Vthis_command))
 +	/* nil means key is undefined.  */
 +	call0 (Qundefined);
 +      else
 +	{
 +	  /* Here for a command that isn't executed directly.  */
 +
 +#ifdef HAVE_WINDOW_SYSTEM
 +            ptrdiff_t scount = SPECPDL_INDEX ();
 +
 +            if (display_hourglass_p
 +                && NILP (Vexecuting_kbd_macro))
 +              {
 +                record_unwind_protect_void (cancel_hourglass);
 +                start_hourglass ();
 +              }
 +#endif
 +
 +            if (NILP (KVAR (current_kboard, Vprefix_arg))) /* FIXME: Why?  --Stef  */
 +              {
 +		Lisp_Object undo = BVAR (current_buffer, undo_list);
 +		Fundo_boundary ();
 +		last_undo_boundary
 +		  = (EQ (undo, BVAR (current_buffer, undo_list))
 +		     ? Qnil : BVAR (current_buffer, undo_list));
 +	      }
 +            call1 (Qcommand_execute, Vthis_command);
 +
 +#ifdef HAVE_WINDOW_SYSTEM
 +	  /* Do not check display_hourglass_p here, because
 +	     `command-execute' could change it, but we should cancel
 +	     hourglass cursor anyway.
 +	     But don't cancel the hourglass within a macro
 +	     just because a command in the macro finishes.  */
 +	  if (NILP (Vexecuting_kbd_macro))
 +            unbind_to (scount, Qnil);
 +#endif
 +          }
 +      kset_last_prefix_arg (current_kboard, Vcurrent_prefix_arg);
 +
 +      safe_run_hooks (Qpost_command_hook);
 +
 +      /* If displaying a message, resize the echo area window to fit
 +	 that message's size exactly.  */
 +      if (!NILP (echo_area_buffer[0]))
 +	resize_echo_area_exactly ();
 +
 +      /* If there are warnings waiting, process them.  */
 +      if (!NILP (Vdelayed_warnings_list))
 +        safe_run_hooks (Qdelayed_warnings_hook);
 +
 +      safe_run_hooks (Qdeferred_action_function);
 +
 +      /* If there is a prefix argument,
 +	 1) We don't want Vlast_command to be ``universal-argument''
 +	 (that would be dumb), so don't set Vlast_command,
 +	 2) we want to leave echoing on so that the prefix will be
 +	 echoed as part of this key sequence, so don't call
 +	 cancel_echoing, and
 +	 3) we want to leave this_command_key_count non-zero, so that
 +	 read_char will realize that it is re-reading a character, and
 +	 not echo it a second time.
 +
 +	 If the command didn't actually create a prefix arg,
 +	 but is merely a frame event that is transparent to prefix args,
 +	 then the above doesn't apply.  */
 +      if (NILP (KVAR (current_kboard, Vprefix_arg))
 +	  || CONSP (last_command_event))
 +	{
 +	  kset_last_command (current_kboard, Vthis_command);
 +	  kset_real_last_command (current_kboard, Vreal_this_command);
 +	  if (!CONSP (last_command_event))
 +	    kset_last_repeatable_command (current_kboard, Vreal_this_command);
 +	  cancel_echoing ();
 +	  this_command_key_count = 0;
 +	  this_command_key_count_reset = 0;
 +	  this_single_command_key_start = 0;
 +	}
 +
 +      if (!NILP (BVAR (current_buffer, mark_active))
 +	  && !NILP (Vrun_hooks))
 +	{
 +	  /* In Emacs 22, setting transient-mark-mode to `only' was a
 +	     way of turning it on for just one command.  This usage is
 +	     obsolete, but support it anyway.  */
 +	  if (EQ (Vtransient_mark_mode, Qidentity))
 +	    Vtransient_mark_mode = Qnil;
 +	  else if (EQ (Vtransient_mark_mode, Qonly))
 +	    Vtransient_mark_mode = Qidentity;
 +
 +	  if (!NILP (Vdeactivate_mark))
 +	    /* If `select-active-regions' is non-nil, this call to
 +	       `deactivate-mark' also sets the PRIMARY selection.  */
 +	    call0 (Qdeactivate_mark);
 +	  else
 +	    {
 +	      /* Even if not deactivating the mark, set PRIMARY if
 +		 `select-active-regions' is non-nil.  */
 +	      if (!NILP (Fwindow_system (Qnil))
 +		  /* Even if mark_active is non-nil, the actual buffer
 +		     marker may not have been set yet (Bug#7044).  */
 +		  && XMARKER (BVAR (current_buffer, mark))->buffer
 +		  && (EQ (Vselect_active_regions, Qonly)
 +		      ? EQ (CAR_SAFE (Vtransient_mark_mode), Qonly)
 +		      : (!NILP (Vselect_active_regions)
 +			 && !NILP (Vtransient_mark_mode)))
 +		  && NILP (Fmemq (Vthis_command,
 +				  Vselection_inhibit_update_commands)))
 +		{
 +		  Lisp_Object txt
 +		    = call1 (Fsymbol_value (Qregion_extract_function), Qnil);
 +		  if (XINT (Flength (txt)) > 0)
 +		    /* Don't set empty selections.  */
 +		    call2 (Qgui_set_selection, QPRIMARY, txt);
 +		}
 +
 +	      if (current_buffer != prev_buffer || MODIFF != prev_modiff)
 +		run_hook (intern ("activate-mark-hook"));
 +	    }
 +
 +	  Vsaved_region_selection = Qnil;
 +	}
 +
 +    finalize:
 +
 +      if (current_buffer == prev_buffer
 +	  && last_point_position != PT
 +	  && NILP (Vdisable_point_adjustment)
 +	  && NILP (Vglobal_disable_point_adjustment))
 +	{
 +	  if (last_point_position > BEGV
 +	      && last_point_position < ZV
 +	      && (composition_adjust_point (last_point_position,
 +					    last_point_position)
 +		  != last_point_position))
 +	    /* The last point was temporarily set within a grapheme
 +	       cluster to prevent automatic composition.  To recover
 +	       the automatic composition, we must update the
 +	       display.  */
 +	    windows_or_buffers_changed = 21;
 +	  if (!already_adjusted)
 +	    adjust_point_for_property (last_point_position,
 +				       MODIFF != prev_modiff);
 +	}
 +
 +      /* Install chars successfully executed in kbd macro.  */
 +
 +      if (!NILP (KVAR (current_kboard, defining_kbd_macro))
 +	  && NILP (KVAR (current_kboard, Vprefix_arg)))
 +	finalize_kbd_macro_chars ();
 +    }
 +}
 +
 +Lisp_Object
 +read_menu_command (void)
 +{
 +  Lisp_Object keybuf[30];
 +  ptrdiff_t count = SPECPDL_INDEX ();
 +  int i;
 +
 +  /* We don't want to echo the keystrokes while navigating the
 +     menus.  */
 +  specbind (Qecho_keystrokes, make_number (0));
 +
 +  i = read_key_sequence (keybuf, ARRAYELTS (keybuf),
 +			 Qnil, 0, 1, 1, 1);
 +
 +  unbind_to (count, Qnil);
 +
 +  if (! FRAME_LIVE_P (XFRAME (selected_frame)))
 +    Fkill_emacs (Qnil);
 +  if (i == 0 || i == -1)
 +    return Qt;
 +
 +  return read_key_sequence_cmd;
 +}
 +
 +/* Adjust point to a boundary of a region that has such a property
 +   that should be treated intangible.  For the moment, we check
 +   `composition', `display' and `invisible' properties.
 +   LAST_PT is the last position of point.  */
 +
 +static void
 +adjust_point_for_property (ptrdiff_t last_pt, bool modified)
 +{
 +  ptrdiff_t beg, end;
 +  Lisp_Object val, overlay, tmp;
 +  /* When called after buffer modification, we should temporarily
 +     suppress the point adjustment for automatic composition so that a
 +     user can keep inserting another character at point or keep
 +     deleting characters around point.  */
 +  bool check_composition = ! modified, check_display = 1, check_invisible = 1;
 +  ptrdiff_t orig_pt = PT;
 +
 +  /* FIXME: cycling is probably not necessary because these properties
 +     can't be usefully combined anyway.  */
 +  while (check_composition || check_display || check_invisible)
 +    {
 +      /* FIXME: check `intangible'.  */
 +      if (check_composition
 +	  && PT > BEGV && PT < ZV
 +	  && (beg = composition_adjust_point (last_pt, PT)) != PT)
 +	{
 +	  SET_PT (beg);
 +	  check_display = check_invisible = 1;
 +	}
 +      check_composition = 0;
 +      if (check_display
 +	  && PT > BEGV && PT < ZV
 +	  && !NILP (val = get_char_property_and_overlay
 +		              (make_number (PT), Qdisplay, Qnil, &overlay))
 +	  && display_prop_intangible_p (val, overlay, PT, PT_BYTE)
 +	  && (!OVERLAYP (overlay)
 +	      ? get_property_and_range (PT, Qdisplay, &val, &beg, &end, Qnil)
 +	      : (beg = OVERLAY_POSITION (OVERLAY_START (overlay)),
 +		 end = OVERLAY_POSITION (OVERLAY_END (overlay))))
 +	  && (beg < PT /* && end > PT   <- It's always the case.  */
 +	      || (beg <= PT && STRINGP (val) && SCHARS (val) == 0)))
 +	{
 +	  eassert (end > PT);
 +	  SET_PT (PT < last_pt
 +		  ? (STRINGP (val) && SCHARS (val) == 0
 +		     ? max (beg - 1, BEGV)
 +		     : beg)
 +		  : end);
 +	  check_composition = check_invisible = 1;
 +	}
 +      check_display = 0;
 +      if (check_invisible && PT > BEGV && PT < ZV)
 +	{
 +	  int inv;
 +	  bool ellipsis = 0;
 +	  beg = end = PT;
 +
 +	  /* Find boundaries `beg' and `end' of the invisible area, if any.  */
 +	  while (end < ZV
 +#if 0
 +		 /* FIXME: We should stop if we find a spot between
 +		    two runs of `invisible' where inserted text would
 +		    be visible.  This is important when we have two
 +		    invisible boundaries that enclose an area: if the
 +		    area is empty, we need this test in order to make
 +		    it possible to place point in the middle rather
 +		    than skip both boundaries.  However, this code
 +		    also stops anywhere in a non-sticky text-property,
 +		    which breaks (e.g.) Org mode.  */
 +		 && (val = Fget_pos_property (make_number (end),
 +					      Qinvisible, Qnil),
 +		     TEXT_PROP_MEANS_INVISIBLE (val))
 +#endif
 +		 && !NILP (val = get_char_property_and_overlay
 +		           (make_number (end), Qinvisible, Qnil, &overlay))
 +		 && (inv = TEXT_PROP_MEANS_INVISIBLE (val)))
 +	    {
 +	      ellipsis = ellipsis || inv > 1
 +		|| (OVERLAYP (overlay)
 +		    && (!NILP (Foverlay_get (overlay, Qafter_string))
 +			|| !NILP (Foverlay_get (overlay, Qbefore_string))));
 +	      tmp = Fnext_single_char_property_change
 +		(make_number (end), Qinvisible, Qnil, Qnil);
 +	      end = NATNUMP (tmp) ? XFASTINT (tmp) : ZV;
 +	    }
 +	  while (beg > BEGV
 +#if 0
 +		 && (val = Fget_pos_property (make_number (beg),
 +					      Qinvisible, Qnil),
 +		     TEXT_PROP_MEANS_INVISIBLE (val))
 +#endif
 +		 && !NILP (val = get_char_property_and_overlay
 +		           (make_number (beg - 1), Qinvisible, Qnil, &overlay))
 +		 && (inv = TEXT_PROP_MEANS_INVISIBLE (val)))
 +	    {
 +	      ellipsis = ellipsis || inv > 1
 +		|| (OVERLAYP (overlay)
 +		    && (!NILP (Foverlay_get (overlay, Qafter_string))
 +			|| !NILP (Foverlay_get (overlay, Qbefore_string))));
 +	      tmp = Fprevious_single_char_property_change
 +		(make_number (beg), Qinvisible, Qnil, Qnil);
 +	      beg = NATNUMP (tmp) ? XFASTINT (tmp) : BEGV;
 +	    }
 +
 +	  /* Move away from the inside area.  */
 +	  if (beg < PT && end > PT)
 +	    {
 +	      SET_PT ((orig_pt == PT && (last_pt < beg || last_pt > end))
 +		      /* We haven't moved yet (so we don't need to fear
 +			 infinite-looping) and we were outside the range
 +			 before (so either end of the range still corresponds
 +			 to a move in the right direction): pretend we moved
 +			 less than we actually did, so that we still have
 +			 more freedom below in choosing which end of the range
 +			 to go to.  */
 +		      ? (orig_pt = -1, PT < last_pt ? end : beg)
 +		      /* We either have moved already or the last point
 +			 was already in the range: we don't get to choose
 +			 which end of the range we have to go to.  */
 +		      : (PT < last_pt ? beg : end));
 +	      check_composition = check_display = 1;
 +	    }
 +#if 0 /* This assertion isn't correct, because SET_PT may end up setting
 +	 the point to something other than its argument, due to
 +	 point-motion hooks, intangibility, etc.  */
 +	  eassert (PT == beg || PT == end);
 +#endif
 +
 +	  /* Pretend the area doesn't exist if the buffer is not
 +	     modified.  */
 +	  if (!modified && !ellipsis && beg < end)
 +	    {
 +	      if (last_pt == beg && PT == end && end < ZV)
 +		(check_composition = check_display = 1, SET_PT (end + 1));
 +	      else if (last_pt == end && PT == beg && beg > BEGV)
 +		(check_composition = check_display = 1, SET_PT (beg - 1));
 +	      else if (PT == ((PT < last_pt) ? beg : end))
 +		/* We've already moved as far as we can.  Trying to go
 +		   to the other end would mean moving backwards and thus
 +		   could lead to an infinite loop.  */
 +		;
 +	      else if (val = Fget_pos_property (make_number (PT),
 +						Qinvisible, Qnil),
 +		       TEXT_PROP_MEANS_INVISIBLE (val)
 +		       && (val = (Fget_pos_property
 +				  (make_number (PT == beg ? end : beg),
 +				   Qinvisible, Qnil)),
 +			   !TEXT_PROP_MEANS_INVISIBLE (val)))
 +		(check_composition = check_display = 1,
 +		 SET_PT (PT == beg ? end : beg));
 +	    }
 +	}
 +      check_invisible = 0;
 +    }
 +}
 +
 +/* Subroutine for safe_run_hooks: run the hook, which is ARGS[1].  */
 +
 +static Lisp_Object
 +safe_run_hooks_1 (ptrdiff_t nargs, Lisp_Object *args)
 +{
 +  eassert (nargs == 2);
 +  return call0 (args[1]);
 +}
 +
 +/* Subroutine for safe_run_hooks: handle an error by clearing out the function
 +   from the hook.  */
 +
 +static Lisp_Object
 +safe_run_hooks_error (Lisp_Object error, ptrdiff_t nargs, Lisp_Object *args)
 +{
 +  eassert (nargs == 2);
 +  AUTO_STRING (format, "Error in %s (%S): %S");
 +  Lisp_Object hook = args[0];
 +  Lisp_Object fun = args[1];
 +  CALLN (Fmessage, format, hook, fun, error);
 +
 +  if (SYMBOLP (hook))
 +    {
 +      Lisp_Object val;
 +      bool found = 0;
 +      Lisp_Object newval = Qnil;
 +      for (val = find_symbol_value (hook); CONSP (val); val = XCDR (val))
 +	if (EQ (fun, XCAR (val)))
 +	  found = 1;
 +	else
 +	  newval = Fcons (XCAR (val), newval);
 +      if (found)
 +	return Fset (hook, Fnreverse (newval));
 +      /* Not found in the local part of the hook.  Let's look at the global
 +	 part.  */
 +      newval = Qnil;
 +      for (val = (NILP (Fdefault_boundp (hook)) ? Qnil
 +		  : Fdefault_value (hook));
 +	   CONSP (val); val = XCDR (val))
 +	if (EQ (fun, XCAR (val)))
 +	  found = 1;
 +	else
 +	  newval = Fcons (XCAR (val), newval);
 +      if (found)
 +	return Fset_default (hook, Fnreverse (newval));
 +    }
 +  return Qnil;
 +}
 +
 +static Lisp_Object
 +safe_run_hook_funcall (ptrdiff_t nargs, Lisp_Object *args)
 +{
 +  eassert (nargs == 2);
 +  /* Yes, run_hook_with_args works with args in the other order.  */
 +  internal_condition_case_n (safe_run_hooks_1,
 +			     2, ((Lisp_Object []) {args[1], args[0]}),
 +			     Qt, safe_run_hooks_error);
 +  return Qnil;
 +}
 +
 +/* If we get an error while running the hook, cause the hook variable
 +   to be nil.  Also inhibit quits, so that C-g won't cause the hook
 +   to mysteriously evaporate.  */
 +
 +void
 +safe_run_hooks (Lisp_Object hook)
 +{
 +  struct gcpro gcpro1;
 +  ptrdiff_t count = SPECPDL_INDEX ();
 +
 +  GCPRO1 (hook);
 +  specbind (Qinhibit_quit, Qt);
 +  run_hook_with_args (2, ((Lisp_Object []) {hook, hook}), safe_run_hook_funcall);
 +  unbind_to (count, Qnil);
 +  UNGCPRO;
 +}
 +
 +
 +/* Nonzero means polling for input is temporarily suppressed.  */
 +
 +int poll_suppress_count;
 +
 +
 +#ifdef POLL_FOR_INPUT
 +
 +/* Asynchronous timer for polling.  */
 +
 +static struct atimer *poll_timer;
 +
 +/* Poll for input, so that we catch a C-g if it comes in.  */
 +void
 +poll_for_input_1 (void)
 +{
 +  if (! input_blocked_p ()
 +      && !waiting_for_input)
 +    gobble_input ();
 +}
 +
 +/* Timer callback function for poll_timer.  TIMER is equal to
 +   poll_timer.  */
 +
 +static void
 +poll_for_input (struct atimer *timer)
 +{
 +  if (poll_suppress_count == 0)
 +    pending_signals = 1;
 +}
 +
 +#endif /* POLL_FOR_INPUT */
 +
 +/* Begin signals to poll for input, if they are appropriate.
 +   This function is called unconditionally from various places.  */
 +
 +void
 +start_polling (void)
 +{
 +#ifdef POLL_FOR_INPUT
 +  /* XXX This condition was (read_socket_hook && !interrupt_input),
 +     but read_socket_hook is not global anymore.  Let's pretend that
 +     it's always set.  */
 +  if (!interrupt_input)
 +    {
 +      /* Turn alarm handling on unconditionally.  It might have
 +	 been turned off in process.c.  */
 +      turn_on_atimers (1);
 +
 +      /* If poll timer doesn't exist, or we need one with
 +	 a different interval, start a new one.  */
 +      if (poll_timer == NULL
 +	  || poll_timer->interval.tv_sec != polling_period)
 +	{
 +	  time_t period = max (1, min (polling_period, TYPE_MAXIMUM (time_t)));
 +	  struct timespec interval = make_timespec (period, 0);
 +
 +	  if (poll_timer)
 +	    cancel_atimer (poll_timer);
 +
 +	  poll_timer = start_atimer (ATIMER_CONTINUOUS, interval,
 +				     poll_for_input, NULL);
 +	}
 +
 +      /* Let the timer's callback function poll for input
 +	 if this becomes zero.  */
 +      --poll_suppress_count;
 +    }
 +#endif
 +}
 +
 +/* True if we are using polling to handle input asynchronously.  */
 +
 +bool
 +input_polling_used (void)
 +{
 +#ifdef POLL_FOR_INPUT
 +  /* XXX This condition was (read_socket_hook && !interrupt_input),
 +     but read_socket_hook is not global anymore.  Let's pretend that
 +     it's always set.  */
 +  return !interrupt_input;
 +#else
 +  return 0;
 +#endif
 +}
 +
 +/* Turn off polling.  */
 +
 +void
 +stop_polling (void)
 +{
 +#ifdef POLL_FOR_INPUT
 +  /* XXX This condition was (read_socket_hook && !interrupt_input),
 +     but read_socket_hook is not global anymore.  Let's pretend that
 +     it's always set.  */
 +  if (!interrupt_input)
 +    ++poll_suppress_count;
 +#endif
 +}
 +
 +/* Set the value of poll_suppress_count to COUNT
 +   and start or stop polling accordingly.  */
 +
 +void
 +set_poll_suppress_count (int count)
 +{
 +#ifdef POLL_FOR_INPUT
 +  if (count == 0 && poll_suppress_count != 0)
 +    {
 +      poll_suppress_count = 1;
 +      start_polling ();
 +    }
 +  else if (count != 0 && poll_suppress_count == 0)
 +    {
 +      stop_polling ();
 +    }
 +  poll_suppress_count = count;
 +#endif
 +}
 +
 +/* Bind polling_period to a value at least N.
 +   But don't decrease it.  */
 +
 +void
 +bind_polling_period (int n)
 +{
 +#ifdef POLL_FOR_INPUT
 +  EMACS_INT new = polling_period;
 +
 +  if (n > new)
 +    new = n;
 +
 +  stop_other_atimers (poll_timer);
 +  stop_polling ();
 +  specbind (Qpolling_period, make_number (new));
 +  /* Start a new alarm with the new period.  */
 +  start_polling ();
 +#endif
 +}
 +
 +/* Apply the control modifier to CHARACTER.  */
 +
 +int
 +make_ctrl_char (int c)
 +{
 +  /* Save the upper bits here.  */
 +  int upper = c & ~0177;
 +
 +  if (! ASCII_CHAR_P (c))
 +    return c |= ctrl_modifier;
 +
 +  c &= 0177;
 +
 +  /* Everything in the columns containing the upper-case letters
 +     denotes a control character.  */
 +  if (c >= 0100 && c < 0140)
 +    {
 +      int oc = c;
 +      c &= ~0140;
 +      /* Set the shift modifier for a control char
 +	 made from a shifted letter.  But only for letters!  */
 +      if (oc >= 'A' && oc <= 'Z')
 +	c |= shift_modifier;
 +    }
 +
 +  /* The lower-case letters denote control characters too.  */
 +  else if (c >= 'a' && c <= 'z')
 +    c &= ~0140;
 +
 +  /* Include the bits for control and shift
 +     only if the basic ASCII code can't indicate them.  */
 +  else if (c >= ' ')
 +    c |= ctrl_modifier;
 +
 +  /* Replace the high bits.  */
 +  c |= (upper & ~ctrl_modifier);
 +
 +  return c;
 +}
 +
 +/* Display the help-echo property of the character after the mouse pointer.
 +   Either show it in the echo area, or call show-help-function to display
 +   it by other means (maybe in a tooltip).
 +
 +   If HELP is nil, that means clear the previous help echo.
 +
 +   If HELP is a string, display that string.  If HELP is a function,
 +   call it with OBJECT and POS as arguments; the function should
 +   return a help string or nil for none.  For all other types of HELP,
 +   evaluate it to obtain a string.
 +
 +   WINDOW is the window in which the help was generated, if any.
 +   It is nil if not in a window.
 +
 +   If OBJECT is a buffer, POS is the position in the buffer where the
 +   `help-echo' text property was found.
 +
 +   If OBJECT is an overlay, that overlay has a `help-echo' property,
 +   and POS is the position in the overlay's buffer under the mouse.
 +
 +   If OBJECT is a string (an overlay string or a string displayed with
 +   the `display' property).  POS is the position in that string under
 +   the mouse.
 +
 +   Note: this function may only be called with HELP nil or a string
 +   from X code running asynchronously.  */
 +
 +void
 +show_help_echo (Lisp_Object help, Lisp_Object window, Lisp_Object object,
 +		Lisp_Object pos)
 +{
 +  if (!NILP (help) && !STRINGP (help))
 +    {
 +      if (FUNCTIONP (help))
 +	help = safe_call (4, help, window, object, pos);
 +      else
 +	help = safe_eval (help);
 +
 +      if (!STRINGP (help))
 +	return;
 +    }
 +
 +  if (!noninteractive && STRINGP (help))
 +    {
 +      /* The mouse-fixup-help-message Lisp function can call
 +	 mouse_position_hook, which resets the mouse_moved flags.
 +	 This causes trouble if we are trying to read a mouse motion
 +	 event (i.e., if we are inside a `track-mouse' form), so we
 +	 restore the mouse_moved flag.  */
 +      struct frame *f = NILP (do_mouse_tracking) ? NULL : some_mouse_moved ();
 +      help = call1 (Qmouse_fixup_help_message, help);
 +      if (f)
 +      	f->mouse_moved = 1;
 +    }
 +
 +  if (STRINGP (help) || NILP (help))
 +    {
 +      if (!NILP (Vshow_help_function))
 +	call1 (Vshow_help_function, help);
 +      help_echo_showing_p = STRINGP (help);
 +    }
 +}
 +
 +
 +
 +/* Input of single characters from keyboard.  */
 +
 +static Lisp_Object kbd_buffer_get_event (KBOARD **kbp, bool *used_mouse_menu,
 +					 struct timespec *end_time);
 +static void record_char (Lisp_Object c);
 +
 +static Lisp_Object help_form_saved_window_configs;
 +static void
 +read_char_help_form_unwind (void)
 +{
 +  Lisp_Object window_config = XCAR (help_form_saved_window_configs);
 +  help_form_saved_window_configs = XCDR (help_form_saved_window_configs);
 +  if (!NILP (window_config))
 +    Fset_window_configuration (window_config);
 +}
 +
 +#define STOP_POLLING					\
 +do { if (! polling_stopped_here) stop_polling ();	\
 +       polling_stopped_here = 1; } while (0)
 +
 +#define RESUME_POLLING					\
 +do { if (polling_stopped_here) start_polling ();	\
 +       polling_stopped_here = 0; } while (0)
 +
 +static Lisp_Object
 +read_event_from_main_queue (struct timespec *end_time,
 +                            sys_jmp_buf local_getcjmp,
 +                            bool *used_mouse_menu)
 +{
 +  Lisp_Object c = Qnil;
 +  sys_jmp_buf save_jump;
 +  KBOARD *kb IF_LINT (= NULL);
 +
 + start:
 +
 +  /* Read from the main queue, and if that gives us something we can't use yet,
 +     we put it on the appropriate side queue and try again.  */
 +
 +  if (end_time && timespec_cmp (*end_time, current_timespec ()) <= 0)
 +    return c;
 +
 +  /* Actually read a character, waiting if necessary.  */
 +  save_getcjmp (save_jump);
 +  restore_getcjmp (local_getcjmp);
 +  if (!end_time)
 +    timer_start_idle ();
 +  c = kbd_buffer_get_event (&kb, used_mouse_menu, end_time);
 +  restore_getcjmp (save_jump);
 +
 +  if (! NILP (c) && (kb != current_kboard))
 +    {
 +      Lisp_Object last = KVAR (kb, kbd_queue);
 +      if (CONSP (last))
 +        {
 +          while (CONSP (XCDR (last)))
 +      	last = XCDR (last);
 +          if (!NILP (XCDR (last)))
 +      	emacs_abort ();
 +        }
 +      if (!CONSP (last))
 +        kset_kbd_queue (kb, list1 (c));
 +      else
 +        XSETCDR (last, list1 (c));
 +      kb->kbd_queue_has_data = 1;
 +      c = Qnil;
 +      if (single_kboard)
 +        goto start;
 +      current_kboard = kb;
 +      /* This is going to exit from read_char
 +         so we had better get rid of this frame's stuff.  */
 +      return make_number (-2);
 +    }
 +
 +  /* Terminate Emacs in batch mode if at eof.  */
 +  if (noninteractive && INTEGERP (c) && XINT (c) < 0)
 +    Fkill_emacs (make_number (1));
 +
 +  if (INTEGERP (c))
 +    {
 +      /* Add in any extra modifiers, where appropriate.  */
 +      if ((extra_keyboard_modifiers & CHAR_CTL)
 +	  || ((extra_keyboard_modifiers & 0177) < ' '
 +	      && (extra_keyboard_modifiers & 0177) != 0))
 +	XSETINT (c, make_ctrl_char (XINT (c)));
 +
 +      /* Transfer any other modifier bits directly from
 +	 extra_keyboard_modifiers to c.  Ignore the actual character code
 +	 in the low 16 bits of extra_keyboard_modifiers.  */
 +      XSETINT (c, XINT (c) | (extra_keyboard_modifiers & ~0xff7f & ~CHAR_CTL));
 +    }
 +
 +  return c;
 +}
 +
 +
 +
 +/* Like `read_event_from_main_queue' but applies keyboard-coding-system
 +   to tty input.  */
 +static Lisp_Object
 +read_decoded_event_from_main_queue (struct timespec *end_time,
 +                                    sys_jmp_buf local_getcjmp,
 +                                    Lisp_Object prev_event,
 +                                    bool *used_mouse_menu)
 +{
 +#define MAX_ENCODED_BYTES 16
 +#ifndef WINDOWSNT
 +  Lisp_Object events[MAX_ENCODED_BYTES];
 +  int n = 0;
 +#endif
 +  while (true)
 +    {
 +      Lisp_Object nextevt
 +        = read_event_from_main_queue (end_time, local_getcjmp,
 +                                      used_mouse_menu);
 +#ifdef WINDOWSNT
 +      /* w32_console already returns decoded events.  It either reads
 +	 Unicode characters from the Windows keyboard input, or
 +	 converts characters encoded in the current codepage into
 +	 Unicode.  See w32inevt.c:key_event, near its end.  */
 +      return nextevt;
 +#else
 +      struct frame *frame = XFRAME (selected_frame);
 +      struct terminal *terminal = frame->terminal;
 +      if (!((FRAME_TERMCAP_P (frame) || FRAME_MSDOS_P (frame))
 +            /* Don't apply decoding if we're just reading a raw event
 +               (e.g. reading bytes sent by the xterm to specify the position
 +               of a mouse click).  */
 +            && (!EQ (prev_event, Qt))
 +	    && (TERMINAL_KEYBOARD_CODING (terminal)->common_flags
 +		& CODING_REQUIRE_DECODING_MASK)))
 +	return nextevt;		/* No decoding needed.  */
 +      else
 +	{
 +	  int meta_key = terminal->display_info.tty->meta_key;
 +	  eassert (n < MAX_ENCODED_BYTES);
 +	  events[n++] = nextevt;
 +	  if (NATNUMP (nextevt)
 +	      && XINT (nextevt) < (meta_key == 1 ? 0x80 : 0x100))
 +	    { /* An encoded byte sequence, let's try to decode it.  */
 +	      struct coding_system *coding
 +		= TERMINAL_KEYBOARD_CODING (terminal);
 +
 +	      if (raw_text_coding_system_p (coding))
 +		{
 +		  int i;
 +		  if (meta_key != 2)
 +		    for (i = 0; i < n; i++)
 +		      events[i] = make_number (XINT (events[i]) & ~0x80);
 +		}
 +	      else
 +		{
 +		  unsigned char src[MAX_ENCODED_BYTES];
 +		  unsigned char dest[MAX_ENCODED_BYTES * MAX_MULTIBYTE_LENGTH];
 +		  int i;
 +		  for (i = 0; i < n; i++)
 +		    src[i] = XINT (events[i]);
 +		  if (meta_key != 2)
 +		    for (i = 0; i < n; i++)
 +		      src[i] &= ~0x80;
 +		  coding->destination = dest;
 +		  coding->dst_bytes = sizeof dest;
 +		  decode_coding_c_string (coding, src, n, Qnil);
 +		  eassert (coding->produced_char <= n);
 +		  if (coding->produced_char == 0)
 +		    { /* The encoded sequence is incomplete.  */
 +		      if (n < MAX_ENCODED_BYTES) /* Avoid buffer overflow.  */
 +			continue;		     /* Read on!  */
 +		    }
 +		  else
 +		    {
 +		      const unsigned char *p = coding->destination;
 +		      eassert (coding->carryover_bytes == 0);
 +		      n = 0;
 +		      while (n < coding->produced_char)
 +			events[n++] = make_number (STRING_CHAR_ADVANCE (p));
 +		    }
 +		}
 +	    }
 +	  /* Now `events' should hold decoded events.
 +	     Normally, n should be equal to 1, but better not rely on it.
 +	     We can only return one event here, so return the first we
 +	     had and keep the others (if any) for later.  */
 +	  while (n > 1)
 +	    Vunread_command_events
 +	      = Fcons (events[--n], Vunread_command_events);
 +	  return events[0];
 +	}
 +#endif
 +    }
 +}
 +
 +static bool
 +echo_keystrokes_p (void)
 +{
 +  return (FLOATP (Vecho_keystrokes) ? XFLOAT_DATA (Vecho_keystrokes) > 0.0
 +	  : INTEGERP (Vecho_keystrokes) ? XINT (Vecho_keystrokes) > 0 : false);
 +}
 +
 +/* Read a character from the keyboard; call the redisplay if needed.  */
 +/* commandflag 0 means do not autosave, but do redisplay.
 +   -1 means do not redisplay, but do autosave.
 +   -2 means do neither.
 +   1 means do both.
 +
 +   The argument MAP is a keymap for menu prompting.
 +
 +   PREV_EVENT is the previous input event, or nil if we are reading
 +   the first event of a key sequence (or not reading a key sequence).
 +   If PREV_EVENT is t, that is a "magic" value that says
 +   not to run input methods, but in other respects to act as if
 +   not reading a key sequence.
 +
 +   If USED_MOUSE_MENU is non-null, then set *USED_MOUSE_MENU to true
 +   if we used a mouse menu to read the input, or false otherwise.  If
 +   USED_MOUSE_MENU is null, don't dereference it.
 +
 +   Value is -2 when we find input on another keyboard.  A second call
 +   to read_char will read it.
 +
 +   If END_TIME is non-null, it is a pointer to a struct timespec
 +   specifying the maximum time to wait until.  If no input arrives by
 +   that time, stop waiting and return nil.
 +
 +   Value is t if we showed a menu and the user rejected it.  */
 +
 +Lisp_Object
 +read_char (int commandflag, Lisp_Object map,
 +	   Lisp_Object prev_event,
 +	   bool *used_mouse_menu, struct timespec *end_time)
 +{
 +  Lisp_Object c;
 +  ptrdiff_t jmpcount;
 +  sys_jmp_buf local_getcjmp;
 +  sys_jmp_buf save_jump;
 +  Lisp_Object tem, save;
 +  volatile Lisp_Object previous_echo_area_message;
 +  volatile Lisp_Object also_record;
 +  volatile bool reread;
 +  struct gcpro gcpro1, gcpro2;
 +  bool volatile polling_stopped_here = 0;
 +  struct kboard *orig_kboard = current_kboard;
 +
 +  also_record = Qnil;
 +
 +#if 0  /* This was commented out as part of fixing echo for C-u left.  */
 +  before_command_key_count = this_command_key_count;
 +  before_command_echo_length = echo_length ();
 +#endif
 +  c = Qnil;
 +  previous_echo_area_message = Qnil;
 +
 +  GCPRO2 (c, previous_echo_area_message);
 +
 + retry:
 +
 +  if (CONSP (Vunread_post_input_method_events))
 +    {
 +      c = XCAR (Vunread_post_input_method_events);
 +      Vunread_post_input_method_events
 +	= XCDR (Vunread_post_input_method_events);
 +
 +      /* Undo what read_char_x_menu_prompt did when it unread
 +	 additional keys returned by Fx_popup_menu.  */
 +      if (CONSP (c)
 +	  && (SYMBOLP (XCAR (c)) || INTEGERP (XCAR (c)))
 +	  && NILP (XCDR (c)))
 +	c = XCAR (c);
 +
 +      reread = true;
 +      goto reread_first;
 +    }
 +  else
 +    reread = false;
 +
 +
 +  if (CONSP (Vunread_command_events))
 +    {
 +      bool was_disabled = 0;
 +
 +      c = XCAR (Vunread_command_events);
 +      Vunread_command_events = XCDR (Vunread_command_events);
 +
 +      /* Undo what sit-for did when it unread additional keys
 +	 inside universal-argument.  */
 +
 +      if (CONSP (c) && EQ (XCAR (c), Qt))
 +	c = XCDR (c);
 +      else
 +	reread = true;
 +
 +      /* Undo what read_char_x_menu_prompt did when it unread
 +	 additional keys returned by Fx_popup_menu.  */
 +      if (CONSP (c)
 +	  && EQ (XCDR (c), Qdisabled)
 +	  && (SYMBOLP (XCAR (c)) || INTEGERP (XCAR (c))))
 +	{
 +	  was_disabled = 1;
 +	  c = XCAR (c);
 +	}
 +
 +      /* If the queued event is something that used the mouse,
 +         set used_mouse_menu accordingly.  */
 +      if (used_mouse_menu
 +	  /* Also check was_disabled so last-nonmenu-event won't return
 +	     a bad value when submenus are involved.  (Bug#447)  */
 +	  && (EQ (c, Qtool_bar) || EQ (c, Qmenu_bar) || was_disabled))
 +	*used_mouse_menu = 1;
 +
 +      goto reread_for_input_method;
 +    }
 +
 +  if (CONSP (Vunread_input_method_events))
 +    {
 +      c = XCAR (Vunread_input_method_events);
 +      Vunread_input_method_events = XCDR (Vunread_input_method_events);
 +
 +      /* Undo what read_char_x_menu_prompt did when it unread
 +	 additional keys returned by Fx_popup_menu.  */
 +      if (CONSP (c)
 +	  && (SYMBOLP (XCAR (c)) || INTEGERP (XCAR (c)))
 +	  && NILP (XCDR (c)))
 +	c = XCAR (c);
 +      reread = true;
 +      goto reread_for_input_method;
 +    }
 +
 +  this_command_key_count_reset = 0;
 +
 +  if (!NILP (Vexecuting_kbd_macro))
 +    {
 +      /* We set this to Qmacro; since that's not a frame, nobody will
 +	 try to switch frames on us, and the selected window will
 +	 remain unchanged.
 +
 +         Since this event came from a macro, it would be misleading to
 +	 leave internal_last_event_frame set to wherever the last
 +	 real event came from.  Normally, a switch-frame event selects
 +	 internal_last_event_frame after each command is read, but
 +	 events read from a macro should never cause a new frame to be
 +	 selected.  */
 +      Vlast_event_frame = internal_last_event_frame = Qmacro;
 +
 +      /* Exit the macro if we are at the end.
 +	 Also, some things replace the macro with t
 +	 to force an early exit.  */
 +      if (EQ (Vexecuting_kbd_macro, Qt)
 +	  || executing_kbd_macro_index >= XFASTINT (Flength (Vexecuting_kbd_macro)))
 +	{
 +	  XSETINT (c, -1);
 +	  goto exit;
 +	}
 +
 +      c = Faref (Vexecuting_kbd_macro, make_number (executing_kbd_macro_index));
 +      if (STRINGP (Vexecuting_kbd_macro)
 +	  && (XFASTINT (c) & 0x80) && (XFASTINT (c) <= 0xff))
 +	XSETFASTINT (c, CHAR_META | (XFASTINT (c) & ~0x80));
 +
 +      executing_kbd_macro_index++;
 +
 +      goto from_macro;
 +    }
 +
 +  if (!NILP (unread_switch_frame))
 +    {
 +      c = unread_switch_frame;
 +      unread_switch_frame = Qnil;
 +
 +      /* This event should make it into this_command_keys, and get echoed
 +	 again, so we do not set `reread'.  */
 +      goto reread_first;
 +    }
 +
 +  /* If redisplay was requested.  */
 +  if (commandflag >= 0)
 +    {
 +      bool echo_current = EQ (echo_message_buffer, echo_area_buffer[0]);
 +
 +	/* If there is pending input, process any events which are not
 +	   user-visible, such as X selection_request events.  */
 +      if (input_pending
 +	  || detect_input_pending_run_timers (0))
 +	swallow_events (false);		/* May clear input_pending.  */
 +
 +      /* Redisplay if no pending input.  */
 +      while (!(input_pending
 +	       && (input_was_pending || !redisplay_dont_pause)))
 +	{
 +	  input_was_pending = input_pending;
 +	  if (help_echo_showing_p && !EQ (selected_window, minibuf_window))
 +	    redisplay_preserve_echo_area (5);
 +	  else
 +	    redisplay ();
 +
 +	  if (!input_pending)
 +	    /* Normal case: no input arrived during redisplay.  */
 +	    break;
 +
 +	  /* Input arrived and pre-empted redisplay.
 +	     Process any events which are not user-visible.  */
 +	  swallow_events (false);
 +	  /* If that cleared input_pending, try again to redisplay.  */
 +	}
 +
 +      /* Prevent the redisplay we just did
 +	 from messing up echoing of the input after the prompt.  */
 +      if (commandflag == 0 && echo_current)
 +	echo_message_buffer = echo_area_buffer[0];
 +
 +    }
 +
 +  /* Message turns off echoing unless more keystrokes turn it on again.
 +
 +     The code in 20.x for the condition was
 +
 +     1. echo_area_glyphs && *echo_area_glyphs
 +     2. && echo_area_glyphs != current_kboard->echobuf
 +     3. && ok_to_echo_at_next_pause != echo_area_glyphs
 +
 +     (1) means there's a current message displayed
 +
 +     (2) means it's not the message from echoing from the current
 +     kboard.
 +
 +     (3) There's only one place in 20.x where ok_to_echo_at_next_pause
 +     is set to a non-null value.  This is done in read_char and it is
 +     set to echo_area_glyphs after a call to echo_char.  That means
 +     ok_to_echo_at_next_pause is either null or
 +     current_kboard->echobuf with the appropriate current_kboard at
 +     that time.
 +
 +     So, condition (3) means in clear text ok_to_echo_at_next_pause
 +     must be either null, or the current message isn't from echoing at
 +     all, or it's from echoing from a different kboard than the
 +     current one.  */
 +
 +  if (/* There currently is something in the echo area.  */
 +      !NILP (echo_area_buffer[0])
 +      && (/* It's an echo from a different kboard.  */
 +	  echo_kboard != current_kboard
 +	  /* Or we explicitly allow overwriting whatever there is.  */
 +	  || ok_to_echo_at_next_pause == NULL))
 +    cancel_echoing ();
 +  else
 +    echo_dash ();
 +
 +  /* Try reading a character via menu prompting in the minibuf.
 +     Try this before the sit-for, because the sit-for
 +     would do the wrong thing if we are supposed to do
 +     menu prompting. If EVENT_HAS_PARAMETERS then we are reading
 +     after a mouse event so don't try a minibuf menu.  */
 +  c = Qnil;
 +  if (KEYMAPP (map) && INTERACTIVE
 +      && !NILP (prev_event) && ! EVENT_HAS_PARAMETERS (prev_event)
 +      /* Don't bring up a menu if we already have another event.  */
 +      && NILP (Vunread_command_events)
 +      && !detect_input_pending_run_timers (0))
 +    {
 +      c = read_char_minibuf_menu_prompt (commandflag, map);
 +
 +      if (INTEGERP (c) && XINT (c) == -2)
 +        return c;               /* wrong_kboard_jmpbuf */
 +
 +      if (! NILP (c))
 +	goto exit;
 +    }
 +
 +  /* Make a longjmp point for quits to use, but don't alter getcjmp just yet.
 +     We will do that below, temporarily for short sections of code,
 +     when appropriate.  local_getcjmp must be in effect
 +     around any call to sit_for or kbd_buffer_get_event;
 +     it *must not* be in effect when we call redisplay.  */
 +
 +  jmpcount = SPECPDL_INDEX ();
 +  if (sys_setjmp (local_getcjmp))
 +    {
 +      /* Handle quits while reading the keyboard.  */
 +      /* We must have saved the outer value of getcjmp here,
 +	 so restore it now.  */
 +      restore_getcjmp (save_jump);
 +      pthread_sigmask (SIG_SETMASK, &empty_mask, 0);
 +      unbind_to (jmpcount, Qnil);
 +      XSETINT (c, quit_char);
 +      internal_last_event_frame = selected_frame;
 +      Vlast_event_frame = internal_last_event_frame;
 +      /* If we report the quit char as an event,
 +	 don't do so more than once.  */
 +      if (!NILP (Vinhibit_quit))
 +	Vquit_flag = Qnil;
 +
 +      {
 +	KBOARD *kb = FRAME_KBOARD (XFRAME (selected_frame));
 +	if (kb != current_kboard)
 +	  {
 +	    Lisp_Object last = KVAR (kb, kbd_queue);
 +	    /* We shouldn't get here if we were in single-kboard mode!  */
 +	    if (single_kboard)
 +	      emacs_abort ();
 +	    if (CONSP (last))
 +	      {
 +		while (CONSP (XCDR (last)))
 +		  last = XCDR (last);
 +		if (!NILP (XCDR (last)))
 +		  emacs_abort ();
 +	      }
 +	    if (!CONSP (last))
 +	      kset_kbd_queue (kb, list1 (c));
 +	    else
 +	      XSETCDR (last, list1 (c));
 +	    kb->kbd_queue_has_data = 1;
 +	    current_kboard = kb;
 +	    /* This is going to exit from read_char
 +	       so we had better get rid of this frame's stuff.  */
 +	    UNGCPRO;
 +            return make_number (-2); /* wrong_kboard_jmpbuf */
 +	  }
 +      }
 +      goto non_reread;
 +    }
 +
 +  /* Start idle timers if no time limit is supplied.  We don't do it
 +     if a time limit is supplied to avoid an infinite recursion in the
 +     situation where an idle timer calls `sit-for'.  */
 +
 +  if (!end_time)
 +    timer_start_idle ();
 +
 +  /* If in middle of key sequence and minibuffer not active,
 +     start echoing if enough time elapses.  */
 +
 +  if (minibuf_level == 0
 +      && !end_time
 +      && !current_kboard->immediate_echo
 +      && this_command_key_count > 0
 +      && ! noninteractive
 +      && echo_keystrokes_p ()
 +      && (/* No message.  */
 +	  NILP (echo_area_buffer[0])
 +	  /* Or empty message.  */
 +	  || (BUF_BEG (XBUFFER (echo_area_buffer[0]))
 +	      == BUF_Z (XBUFFER (echo_area_buffer[0])))
 +	  /* Or already echoing from same kboard.  */
 +	  || (echo_kboard && ok_to_echo_at_next_pause == echo_kboard)
 +	  /* Or not echoing before and echoing allowed.  */
 +	  || (!echo_kboard && ok_to_echo_at_next_pause)))
 +    {
 +      /* After a mouse event, start echoing right away.
 +	 This is because we are probably about to display a menu,
 +	 and we don't want to delay before doing so.  */
 +      if (EVENT_HAS_PARAMETERS (prev_event))
 +	echo_now ();
 +      else
 +	{
 +	  Lisp_Object tem0;
 +
 +	  save_getcjmp (save_jump);
 +	  restore_getcjmp (local_getcjmp);
 +	  tem0 = sit_for (Vecho_keystrokes, 1, 1);
 +	  restore_getcjmp (save_jump);
 +	  if (EQ (tem0, Qt)
 +	      && ! CONSP (Vunread_command_events))
 +	    echo_now ();
 +	}
 +    }
 +
 +  /* Maybe auto save due to number of keystrokes.  */
 +
 +  if (commandflag != 0 && commandflag != -2
 +      && auto_save_interval > 0
 +      && num_nonmacro_input_events - last_auto_save > max (auto_save_interval, 20)
 +      && !detect_input_pending_run_timers (0))
 +    {
 +      Fdo_auto_save (Qnil, Qnil);
 +      /* Hooks can actually change some buffers in auto save.  */
 +      redisplay ();
 +    }
 +
 +  /* Try reading using an X menu.
 +     This is never confused with reading using the minibuf
 +     because the recursive call of read_char in read_char_minibuf_menu_prompt
 +     does not pass on any keymaps.  */
 +
 +  if (KEYMAPP (map) && INTERACTIVE
 +      && !NILP (prev_event)
 +      && EVENT_HAS_PARAMETERS (prev_event)
 +      && !EQ (XCAR (prev_event), Qmenu_bar)
 +      && !EQ (XCAR (prev_event), Qtool_bar)
 +      /* Don't bring up a menu if we already have another event.  */
 +      && NILP (Vunread_command_events))
 +    {
 +      c = read_char_x_menu_prompt (map, prev_event, used_mouse_menu);
 +
 +      /* Now that we have read an event, Emacs is not idle.  */
 +      if (!end_time)
 +	timer_stop_idle ();
 +
 +      goto exit;
 +    }
 +
 +  /* Maybe autosave and/or garbage collect due to idleness.  */
 +
 +  if (INTERACTIVE && NILP (c))
 +    {
 +      int delay_level;
 +      ptrdiff_t buffer_size;
 +
 +      /* Slow down auto saves logarithmically in size of current buffer,
 +	 and garbage collect while we're at it.  */
 +      if (! MINI_WINDOW_P (XWINDOW (selected_window)))
 +	last_non_minibuf_size = Z - BEG;
 +      buffer_size = (last_non_minibuf_size >> 8) + 1;
 +      delay_level = 0;
 +      while (buffer_size > 64)
 +	delay_level++, buffer_size -= buffer_size >> 2;
 +      if (delay_level < 4) delay_level = 4;
 +      /* delay_level is 4 for files under around 50k, 7 at 100k,
 +	 9 at 200k, 11 at 300k, and 12 at 500k.  It is 15 at 1 meg.  */
 +
 +      /* Auto save if enough time goes by without input.  */
 +      if (commandflag != 0 && commandflag != -2
 +	  && num_nonmacro_input_events > last_auto_save
 +	  && INTEGERP (Vauto_save_timeout)
 +	  && XINT (Vauto_save_timeout) > 0)
 +	{
 +	  Lisp_Object tem0;
 +	  EMACS_INT timeout = XFASTINT (Vauto_save_timeout);
 +
 +	  timeout = min (timeout, MOST_POSITIVE_FIXNUM / delay_level * 4);
 +	  timeout = delay_level * timeout / 4;
 +	  save_getcjmp (save_jump);
 +	  restore_getcjmp (local_getcjmp);
 +	  tem0 = sit_for (make_number (timeout), 1, 1);
 +	  restore_getcjmp (save_jump);
 +
 +	  if (EQ (tem0, Qt)
 +	      && ! CONSP (Vunread_command_events))
 +	    {
 +	      Fdo_auto_save (Qnil, Qnil);
 +	      redisplay ();
 +	    }
 +	}
 +
 +      /* If there is still no input available, ask for GC.  */
 +      if (!detect_input_pending_run_timers (0))
 +	maybe_gc ();
 +    }
 +
 +  /* Notify the caller if an autosave hook, or a timer, sentinel or
 +     filter in the sit_for calls above have changed the current
 +     kboard.  This could happen if they use the minibuffer or start a
 +     recursive edit, like the fancy splash screen in server.el's
 +     filter.  If this longjmp wasn't here, read_key_sequence would
 +     interpret the next key sequence using the wrong translation
 +     tables and function keymaps.  */
 +  if (NILP (c) && current_kboard != orig_kboard)
 +    {
 +      UNGCPRO;
 +      return make_number (-2);  /* wrong_kboard_jmpbuf */
 +    }
 +
 +  /* If this has become non-nil here, it has been set by a timer
 +     or sentinel or filter.  */
 +  if (CONSP (Vunread_command_events))
 +    {
 +      c = XCAR (Vunread_command_events);
 +      Vunread_command_events = XCDR (Vunread_command_events);
 +
 +      if (CONSP (c) && EQ (XCAR (c), Qt))
 +	c = XCDR (c);
 +      else
 +	reread = true;
 +    }
 +
 +  /* Read something from current KBOARD's side queue, if possible.  */
 +
 +  if (NILP (c))
 +    {
 +      if (current_kboard->kbd_queue_has_data)
 +	{
 +	  if (!CONSP (KVAR (current_kboard, kbd_queue)))
 +	    emacs_abort ();
 +	  c = XCAR (KVAR (current_kboard, kbd_queue));
 +	  kset_kbd_queue (current_kboard,
 +			  XCDR (KVAR (current_kboard, kbd_queue)));
 +	  if (NILP (KVAR (current_kboard, kbd_queue)))
 +	    current_kboard->kbd_queue_has_data = 0;
 +	  input_pending = readable_events (0);
 +	  if (EVENT_HAS_PARAMETERS (c)
 +	      && EQ (EVENT_HEAD_KIND (EVENT_HEAD (c)), Qswitch_frame))
 +	    internal_last_event_frame = XCAR (XCDR (c));
 +	  Vlast_event_frame = internal_last_event_frame;
 +	}
 +    }
 +
 +  /* If current_kboard's side queue is empty check the other kboards.
 +     If one of them has data that we have not yet seen here,
 +     switch to it and process the data waiting for it.
 +
 +     Note: if the events queued up for another kboard
 +     have already been seen here, and therefore are not a complete command,
 +     the kbd_queue_has_data field is 0, so we skip that kboard here.
 +     That's to avoid an infinite loop switching between kboards here.  */
 +  if (NILP (c) && !single_kboard)
 +    {
 +      KBOARD *kb;
 +      for (kb = all_kboards; kb; kb = kb->next_kboard)
 +	if (kb->kbd_queue_has_data)
 +	  {
 +	    current_kboard = kb;
 +	    /* This is going to exit from read_char
 +	       so we had better get rid of this frame's stuff.  */
 +	    UNGCPRO;
 +            return make_number (-2); /* wrong_kboard_jmpbuf */
 +	  }
 +    }
 +
 + wrong_kboard:
 +
 +  STOP_POLLING;
 +
 +  if (NILP (c))
 +    {
 +      c = read_decoded_event_from_main_queue (end_time, local_getcjmp,
 +                                              prev_event, used_mouse_menu);
 +      if (NILP (c) && end_time
 +	  && timespec_cmp (*end_time, current_timespec ()) <= 0)
 +        {
 +          goto exit;
 +        }
 +
 +      if (EQ (c, make_number (-2)))
 +        {
 +	  /* This is going to exit from read_char
 +	     so we had better get rid of this frame's stuff.  */
 +	  UNGCPRO;
 +          return c;
 +        }
 +  }
 +
 + non_reread:
 +
 +  if (!end_time)
 +    timer_stop_idle ();
 +  RESUME_POLLING;
 +
 +  if (NILP (c))
 +    {
 +      if (commandflag >= 0
 +	  && !input_pending && !detect_input_pending_run_timers (0))
 +	redisplay ();
 +
 +      goto wrong_kboard;
 +    }
 +
 +  /* Buffer switch events are only for internal wakeups
 +     so don't show them to the user.
 +     Also, don't record a key if we already did.  */
 +  if (BUFFERP (c))
 +    goto exit;
 +
 +  /* Process special events within read_char
 +     and loop around to read another event.  */
 +  save = Vquit_flag;
 +  Vquit_flag = Qnil;
 +  tem = access_keymap (get_keymap (Vspecial_event_map, 0, 1), c, 0, 0, 1);
 +  Vquit_flag = save;
 +
 +  if (!NILP (tem))
 +    {
 +      struct buffer *prev_buffer = current_buffer;
 +      last_input_event = c;
 +      call4 (Qcommand_execute, tem, Qnil, Fvector (1, &last_input_event), Qt);
 +
 +      if (CONSP (c) && EQ (XCAR (c), Qselect_window) && !end_time)
 +	/* We stopped being idle for this event; undo that.  This
 +	   prevents automatic window selection (under
 +	   mouse_autoselect_window from acting as a real input event, for
 +	   example banishing the mouse under mouse-avoidance-mode.  */
 +	timer_resume_idle ();
 +
 +      if (current_buffer != prev_buffer)
 +	{
 +	  /* The command may have changed the keymaps.  Pretend there
 +	     is input in another keyboard and return.  This will
 +	     recalculate keymaps.  */
 +	  c = make_number (-2);
 +	  goto exit;
 +	}
 +      else
 +	goto retry;
 +    }
 +
 +  /* Handle things that only apply to characters.  */
 +  if (INTEGERP (c))
 +    {
 +      /* If kbd_buffer_get_event gave us an EOF, return that.  */
 +      if (XINT (c) == -1)
 +	goto exit;
 +
 +      if ((STRINGP (KVAR (current_kboard, Vkeyboard_translate_table))
 +	   && UNSIGNED_CMP (XFASTINT (c), <,
 +			    SCHARS (KVAR (current_kboard,
 +					  Vkeyboard_translate_table))))
 +	  || (VECTORP (KVAR (current_kboard, Vkeyboard_translate_table))
 +	      && UNSIGNED_CMP (XFASTINT (c), <,
 +			       ASIZE (KVAR (current_kboard,
 +					    Vkeyboard_translate_table))))
 +	  || (CHAR_TABLE_P (KVAR (current_kboard, Vkeyboard_translate_table))
 +	      && CHARACTERP (c)))
 +	{
 +	  Lisp_Object d;
 +	  d = Faref (KVAR (current_kboard, Vkeyboard_translate_table), c);
 +	  /* nil in keyboard-translate-table means no translation.  */
 +	  if (!NILP (d))
 +	    c = d;
 +	}
 +    }
 +
 +  /* If this event is a mouse click in the menu bar,
 +     return just menu-bar for now.  Modify the mouse click event
 +     so we won't do this twice, then queue it up.  */
 +  if (EVENT_HAS_PARAMETERS (c)
 +      && CONSP (XCDR (c))
 +      && CONSP (EVENT_START (c))
 +      && CONSP (XCDR (EVENT_START (c))))
 +    {
 +      Lisp_Object posn;
 +
 +      posn = POSN_POSN (EVENT_START (c));
 +      /* Handle menu-bar events:
 +	 insert the dummy prefix event `menu-bar'.  */
 +      if (EQ (posn, Qmenu_bar) || EQ (posn, Qtool_bar))
 +	{
 +	  /* Change menu-bar to (menu-bar) as the event "position".  */
 +	  POSN_SET_POSN (EVENT_START (c), list1 (posn));
 +
 +	  also_record = c;
 +	  Vunread_command_events = Fcons (c, Vunread_command_events);
 +	  c = posn;
 +	}
 +    }
 +
 +  /* Store these characters into recent_keys, the dribble file if any,
 +     and the keyboard macro being defined, if any.  */
 +  record_char (c);
 +  if (! NILP (also_record))
 +    record_char (also_record);
 +
 +  /* Wipe the echo area.
 +     But first, if we are about to use an input method,
 +     save the echo area contents for it to refer to.  */
 +  if (INTEGERP (c)
 +      && ! NILP (Vinput_method_function)
 +      && ' ' <= XINT (c) && XINT (c) < 256 && XINT (c) != 127)
 +    {
 +      previous_echo_area_message = Fcurrent_message ();
 +      Vinput_method_previous_message = previous_echo_area_message;
 +    }
 +
 +  /* Now wipe the echo area, except for help events which do their
 +     own stuff with the echo area.  */
 +  if (!CONSP (c)
 +      || (!(EQ (Qhelp_echo, XCAR (c)))
 +	  && !(EQ (Qswitch_frame, XCAR (c)))
 +	  /* Don't wipe echo area for select window events: These might
 +	     get delayed via `mouse-autoselect-window' (Bug#11304).  */
 +	  && !(EQ (Qselect_window, XCAR (c)))))
 +    {
 +      if (!NILP (echo_area_buffer[0]))
 +	{
 +	  safe_run_hooks (Qecho_area_clear_hook);
 +	  clear_message (1, 0);
 +	}
 +    }
 +
 + reread_for_input_method:
 + from_macro:
 +  /* Pass this to the input method, if appropriate.  */
 +  if (INTEGERP (c)
 +      && ! NILP (Vinput_method_function)
 +      /* Don't run the input method within a key sequence,
 +	 after the first event of the key sequence.  */
 +      && NILP (prev_event)
 +      && ' ' <= XINT (c) && XINT (c) < 256 && XINT (c) != 127)
 +    {
 +      Lisp_Object keys;
 +      ptrdiff_t key_count;
 +      bool key_count_reset;
 +      ptrdiff_t command_key_start;
 +      struct gcpro gcpro1;
 +      ptrdiff_t count = SPECPDL_INDEX ();
 +
 +      /* Save the echo status.  */
 +      bool saved_immediate_echo = current_kboard->immediate_echo;
 +      struct kboard *saved_ok_to_echo = ok_to_echo_at_next_pause;
 +      Lisp_Object saved_echo_string = KVAR (current_kboard, echo_string);
 +      ptrdiff_t saved_echo_after_prompt = current_kboard->echo_after_prompt;
 +
 +#if 0
 +      if (before_command_restore_flag)
 +	{
 +	  this_command_key_count = before_command_key_count_1;
 +	  if (this_command_key_count < this_single_command_key_start)
 +	    this_single_command_key_start = this_command_key_count;
 +	  echo_truncate (before_command_echo_length_1);
 +	  before_command_restore_flag = 0;
 +	}
 +#endif
 +
 +      /* Save the this_command_keys status.  */
 +      key_count = this_command_key_count;
 +      key_count_reset = this_command_key_count_reset;
 +      command_key_start = this_single_command_key_start;
 +
 +      if (key_count > 0)
 +	keys = Fcopy_sequence (this_command_keys);
 +      else
 +	keys = Qnil;
 +      GCPRO1 (keys);
 +
 +      /* Clear out this_command_keys.  */
 +      this_command_key_count = 0;
 +      this_command_key_count_reset = 0;
 +      this_single_command_key_start = 0;
 +
 +      /* Now wipe the echo area.  */
 +      if (!NILP (echo_area_buffer[0]))
 +	safe_run_hooks (Qecho_area_clear_hook);
 +      clear_message (1, 0);
 +      echo_truncate (0);
 +
 +      /* If we are not reading a key sequence,
 +	 never use the echo area.  */
 +      if (!KEYMAPP (map))
 +	{
 +	  specbind (Qinput_method_use_echo_area, Qt);
 +	}
 +
 +      /* Call the input method.  */
 +      tem = call1 (Vinput_method_function, c);
 +
 +      tem = unbind_to (count, tem);
 +
 +      /* Restore the saved echoing state
 +	 and this_command_keys state.  */
 +      this_command_key_count = key_count;
 +      this_command_key_count_reset = key_count_reset;
 +      this_single_command_key_start = command_key_start;
 +      if (key_count > 0)
 +	this_command_keys = keys;
 +
 +      cancel_echoing ();
 +      ok_to_echo_at_next_pause = saved_ok_to_echo;
 +      /* Do not restore the echo area string when the user is
 +         introducing a prefix argument. Otherwise we end with
 +         repetitions of the partially introduced prefix
 +         argument. (bug#19875) */
 +      if (NILP (intern ("prefix-arg")))
 +        {
 +          kset_echo_string (current_kboard, saved_echo_string);
 +        }
 +      current_kboard->echo_after_prompt = saved_echo_after_prompt;
 +      if (saved_immediate_echo)
 +	echo_now ();
 +
 +      UNGCPRO;
 +
 +      /* The input method can return no events.  */
 +      if (! CONSP (tem))
 +	{
 +	  /* Bring back the previous message, if any.  */
 +	  if (! NILP (previous_echo_area_message))
 +	    message_with_string ("%s", previous_echo_area_message, 0);
 +	  goto retry;
 +	}
 +      /* It returned one event or more.  */
 +      c = XCAR (tem);
 +      Vunread_post_input_method_events
 +	= nconc2 (XCDR (tem), Vunread_post_input_method_events);
 +    }
 +
 + reread_first:
 +
 +  /* Display help if not echoing.  */
 +  if (CONSP (c) && EQ (XCAR (c), Qhelp_echo))
 +    {
 +      /* (help-echo FRAME HELP WINDOW OBJECT POS).  */
 +      Lisp_Object help, object, position, window, htem;
 +
 +      htem = Fcdr (XCDR (c));
 +      help = Fcar (htem);
 +      htem = Fcdr (htem);
 +      window = Fcar (htem);
 +      htem = Fcdr (htem);
 +      object = Fcar (htem);
 +      htem = Fcdr (htem);
 +      position = Fcar (htem);
 +
 +      show_help_echo (help, window, object, position);
 +
 +      /* We stopped being idle for this event; undo that.  */
 +      if (!end_time)
 +	timer_resume_idle ();
 +      goto retry;
 +    }
 +
 +  if ((! reread || this_command_key_count == 0
 +       || this_command_key_count_reset)
 +      && !end_time)
 +    {
 +
 +      /* Don't echo mouse motion events.  */
 +      if (echo_keystrokes_p ()
 +	  && ! (EVENT_HAS_PARAMETERS (c)
 +		&& EQ (EVENT_HEAD_KIND (EVENT_HEAD (c)), Qmouse_movement)))
 +	{
 +	  echo_char (c);
 +	  if (! NILP (also_record))
 +	    echo_char (also_record);
 +	  /* Once we reread a character, echoing can happen
 +	     the next time we pause to read a new one.  */
 +	  ok_to_echo_at_next_pause = current_kboard;
 +	}
 +
 +      /* Record this character as part of the current key.  */
 +      add_command_key (c);
 +      if (! NILP (also_record))
 +	add_command_key (also_record);
 +    }
 +
 +  last_input_event = c;
 +  num_input_events++;
 +
 +  /* Process the help character specially if enabled.  */
 +  if (!NILP (Vhelp_form) && help_char_p (c))
 +    {
 +      ptrdiff_t count = SPECPDL_INDEX ();
 +
 +      help_form_saved_window_configs
 +	= Fcons (Fcurrent_window_configuration (Qnil),
 +		 help_form_saved_window_configs);
 +      record_unwind_protect_void (read_char_help_form_unwind);
 +      call0 (Qhelp_form_show);
 +
 +      cancel_echoing ();
 +      do
 +	{
 +	  c = read_char (0, Qnil, Qnil, 0, NULL);
 +	  if (EVENT_HAS_PARAMETERS (c)
 +	      && EQ (EVENT_HEAD_KIND (EVENT_HEAD (c)), Qmouse_click))
 +	    XSETCAR (help_form_saved_window_configs, Qnil);
 +	}
 +      while (BUFFERP (c));
 +      /* Remove the help from the frame.  */
 +      unbind_to (count, Qnil);
 +
 +      redisplay ();
 +      if (EQ (c, make_number (040)))
 +	{
 +	  cancel_echoing ();
 +	  do
 +	    c = read_char (0, Qnil, Qnil, 0, NULL);
 +	  while (BUFFERP (c));
 +	}
 +    }
 +
 + exit:
 +  RESUME_POLLING;
 +  input_was_pending = input_pending;
 +  RETURN_UNGCPRO (c);
 +}
 +
 +/* Record a key that came from a mouse menu.
 +   Record it for echoing, for this-command-keys, and so on.  */
 +
 +static void
 +record_menu_key (Lisp_Object c)
 +{
 +  /* Wipe the echo area.  */
 +  clear_message (1, 0);
 +
 +  record_char (c);
 +
 +#if 0
 +  before_command_key_count = this_command_key_count;
 +  before_command_echo_length = echo_length ();
 +#endif
 +
 +  /* Don't echo mouse motion events.  */
 +  if (echo_keystrokes_p ())
 +    {
 +      echo_char (c);
 +
 +      /* Once we reread a character, echoing can happen
 +	 the next time we pause to read a new one.  */
 +      ok_to_echo_at_next_pause = 0;
 +    }
 +
 +  /* Record this character as part of the current key.  */
 +  add_command_key (c);
 +
 +  /* Re-reading in the middle of a command.  */
 +  last_input_event = c;
 +  num_input_events++;
 +}
 +
 +/* Return true if should recognize C as "the help character".  */
 +
 +static bool
 +help_char_p (Lisp_Object c)
 +{
 +  Lisp_Object tail;
 +
 +  if (EQ (c, Vhelp_char))
 +    return 1;
 +  for (tail = Vhelp_event_list; CONSP (tail); tail = XCDR (tail))
 +    if (EQ (c, XCAR (tail)))
 +      return 1;
 +  return 0;
 +}
 +
 +/* Record the input event C in various ways.  */
 +
 +static void
 +record_char (Lisp_Object c)
 +{
 +  int recorded = 0;
 +
 +  if (CONSP (c) && (EQ (XCAR (c), Qhelp_echo) || EQ (XCAR (c), Qmouse_movement)))
 +    {
 +      /* To avoid filling recent_keys with help-echo and mouse-movement
 +	 events, we filter out repeated help-echo events, only store the
 +	 first and last in a series of mouse-movement events, and don't
 +	 store repeated help-echo events which are only separated by
 +	 mouse-movement events.  */
 +
 +      Lisp_Object ev1, ev2, ev3;
 +      int ix1, ix2, ix3;
 +
 +      if ((ix1 = recent_keys_index - 1) < 0)
 +	ix1 = NUM_RECENT_KEYS - 1;
 +      ev1 = AREF (recent_keys, ix1);
 +
 +      if ((ix2 = ix1 - 1) < 0)
 +	ix2 = NUM_RECENT_KEYS - 1;
 +      ev2 = AREF (recent_keys, ix2);
 +
 +      if ((ix3 = ix2 - 1) < 0)
 +	ix3 = NUM_RECENT_KEYS - 1;
 +      ev3 = AREF (recent_keys, ix3);
 +
 +      if (EQ (XCAR (c), Qhelp_echo))
 +	{
 +	  /* Don't record `help-echo' in recent_keys unless it shows some help
 +	     message, and a different help than the previously recorded
 +	     event.  */
 +	  Lisp_Object help, last_help;
 +
 +	  help = Fcar_safe (Fcdr_safe (XCDR (c)));
 +	  if (!STRINGP (help))
 +	    recorded = 1;
 +	  else if (CONSP (ev1) && EQ (XCAR (ev1), Qhelp_echo)
 +		   && (last_help = Fcar_safe (Fcdr_safe (XCDR (ev1))), EQ (last_help, help)))
 +	    recorded = 1;
 +	  else if (CONSP (ev1) && EQ (XCAR (ev1), Qmouse_movement)
 +		   && CONSP (ev2) && EQ (XCAR (ev2), Qhelp_echo)
 +		   && (last_help = Fcar_safe (Fcdr_safe (XCDR (ev2))), EQ (last_help, help)))
 +	    recorded = -1;
 +	  else if (CONSP (ev1) && EQ (XCAR (ev1), Qmouse_movement)
 +		   && CONSP (ev2) && EQ (XCAR (ev2), Qmouse_movement)
 +		   && CONSP (ev3) && EQ (XCAR (ev3), Qhelp_echo)
 +		   && (last_help = Fcar_safe (Fcdr_safe (XCDR (ev3))), EQ (last_help, help)))
 +	    recorded = -2;
 +	}
 +      else if (EQ (XCAR (c), Qmouse_movement))
 +	{
 +	  /* Only record one pair of `mouse-movement' on a window in recent_keys.
 +	     So additional mouse movement events replace the last element.  */
 +	  Lisp_Object last_window, window;
 +
 +	  window = Fcar_safe (Fcar_safe (XCDR (c)));
 +	  if (CONSP (ev1) && EQ (XCAR (ev1), Qmouse_movement)
 +	      && (last_window = Fcar_safe (Fcar_safe (XCDR (ev1))), EQ (last_window, window))
 +	      && CONSP (ev2) && EQ (XCAR (ev2), Qmouse_movement)
 +	      && (last_window = Fcar_safe (Fcar_safe (XCDR (ev2))), EQ (last_window, window)))
 +	    {
 +	      ASET (recent_keys, ix1, c);
 +	      recorded = 1;
 +	    }
 +	}
 +    }
 +  else
 +    store_kbd_macro_char (c);
 +
 +  if (!recorded)
 +    {
 +      total_keys += total_keys < NUM_RECENT_KEYS;
 +      ASET (recent_keys, recent_keys_index, c);
 +      if (++recent_keys_index >= NUM_RECENT_KEYS)
 +	recent_keys_index = 0;
 +    }
 +  else if (recorded < 0)
 +    {
 +      /* We need to remove one or two events from recent_keys.
 +         To do this, we simply put nil at those events and move the
 +	 recent_keys_index backwards over those events.  Usually,
 +	 users will never see those nil events, as they will be
 +	 overwritten by the command keys entered to see recent_keys
 +	 (e.g. C-h l).  */
 +
 +      while (recorded++ < 0 && total_keys > 0)
 +	{
 +	  if (total_keys < NUM_RECENT_KEYS)
 +	    total_keys--;
 +	  if (--recent_keys_index < 0)
 +	    recent_keys_index = NUM_RECENT_KEYS - 1;
 +	  ASET (recent_keys, recent_keys_index, Qnil);
 +	}
 +    }
 +
 +  num_nonmacro_input_events++;
 +
 +  /* Write c to the dribble file.  If c is a lispy event, write
 +     the event's symbol to the dribble file, in .  Bleaugh.
 +     If you, dear reader, have a better idea, you've got the source.  :-) */
 +  if (dribble)
 +    {
 +      block_input ();
 +      if (INTEGERP (c))
 +	{
 +	  if (XUINT (c) < 0x100)
 +	    putc (XUINT (c), dribble);
 +	  else
 +	    fprintf (dribble, " 0x%"pI"x", XUINT (c));
 +	}
 +      else
 +	{
 +	  Lisp_Object dribblee;
 +
 +	  /* If it's a structured event, take the event header.  */
 +	  dribblee = EVENT_HEAD (c);
 +
 +	  if (SYMBOLP (dribblee))
 +	    {
 +	      putc ('<', dribble);
 +	      fwrite (SDATA (SYMBOL_NAME (dribblee)), sizeof (char),
 +		      SBYTES (SYMBOL_NAME (dribblee)),
 +		      dribble);
 +	      putc ('>', dribble);
 +	    }
 +	}
 +
 +      fflush (dribble);
 +      unblock_input ();
 +    }
 +}
 +
 +/* Copy out or in the info on where C-g should throw to.
 +   This is used when running Lisp code from within get_char,
 +   in case get_char is called recursively.
 +   See read_process_output.  */
 +
 +static void
 +save_getcjmp (sys_jmp_buf temp)
 +{
 +  memcpy (temp, getcjmp, sizeof getcjmp);
 +}
 +
 +static void
 +restore_getcjmp (sys_jmp_buf temp)
 +{
 +  memcpy (getcjmp, temp, sizeof getcjmp);
 +}
 +
 +/* Low level keyboard/mouse input.
 +   kbd_buffer_store_event places events in kbd_buffer, and
 +   kbd_buffer_get_event retrieves them.  */
 +
 +/* Return true if there are any events in the queue that read-char
 +   would return.  If this returns false, a read-char would block.  */
 +static bool
 +readable_events (int flags)
 +{
 +  if (flags & READABLE_EVENTS_DO_TIMERS_NOW)
 +    timer_check ();
 +
 +  /* If the buffer contains only FOCUS_IN_EVENT events, and
 +     READABLE_EVENTS_FILTER_EVENTS is set, report it as empty.  */
 +  if (kbd_fetch_ptr != kbd_store_ptr)
 +    {
 +      if (flags & (READABLE_EVENTS_FILTER_EVENTS
 +#ifdef USE_TOOLKIT_SCROLL_BARS
 +		   | READABLE_EVENTS_IGNORE_SQUEEZABLES
 +#endif
 +		   ))
 +        {
 +          struct input_event *event;
 +
 +          event = ((kbd_fetch_ptr < kbd_buffer + KBD_BUFFER_SIZE)
 +                   ? kbd_fetch_ptr
 +                   : kbd_buffer);
 +
 +	  do
 +	    {
 +	      if (!(
 +#ifdef USE_TOOLKIT_SCROLL_BARS
 +		    (flags & READABLE_EVENTS_FILTER_EVENTS) &&
 +#endif
 +		    event->kind == FOCUS_IN_EVENT)
 +#ifdef USE_TOOLKIT_SCROLL_BARS
 +		  && !((flags & READABLE_EVENTS_IGNORE_SQUEEZABLES)
 +		       && (event->kind == SCROLL_BAR_CLICK_EVENT
 +			   || event->kind == HORIZONTAL_SCROLL_BAR_CLICK_EVENT)
 +		       && event->part == scroll_bar_handle
 +		       && event->modifiers == 0)
 +#endif
 +		  && !((flags & READABLE_EVENTS_FILTER_EVENTS)
 +		       && event->kind == BUFFER_SWITCH_EVENT))
 +		return 1;
 +	      event++;
 +              if (event == kbd_buffer + KBD_BUFFER_SIZE)
 +                event = kbd_buffer;
 +	    }
 +	  while (event != kbd_store_ptr);
 +        }
 +      else
 +	return 1;
 +    }
 +
 +  if (!(flags & READABLE_EVENTS_IGNORE_SQUEEZABLES)
 +      && !NILP (do_mouse_tracking) && some_mouse_moved ())
 +    return 1;
 +  if (single_kboard)
 +    {
 +      if (current_kboard->kbd_queue_has_data)
 +	return 1;
 +    }
 +  else
 +    {
 +      KBOARD *kb;
 +      for (kb = all_kboards; kb; kb = kb->next_kboard)
 +	if (kb->kbd_queue_has_data)
 +	  return 1;
 +    }
 +  return 0;
 +}
 +
 +/* Set this for debugging, to have a way to get out */
 +int stop_character EXTERNALLY_VISIBLE;
 +
 +static KBOARD *
 +event_to_kboard (struct input_event *event)
 +{
 +  /* Not applicable for these special events.  */
 +  if (event->kind == SELECTION_REQUEST_EVENT
 +      || event->kind == SELECTION_CLEAR_EVENT)
 +    return NULL;
 +  else
 +    {
 +      Lisp_Object obj = event->frame_or_window;
 +      /* There are some events that set this field to nil or string.  */
 +      if (WINDOWP (obj))
 +	obj = WINDOW_FRAME (XWINDOW (obj));
 +      /* Also ignore dead frames here.  */
 +      return ((FRAMEP (obj) && FRAME_LIVE_P (XFRAME (obj)))
 +	      ? FRAME_KBOARD (XFRAME (obj)) : NULL);
 +    }
 +}
 +
 +#ifdef subprocesses
 +/* Return the number of slots occupied in kbd_buffer.  */
 +
 +static int
 +kbd_buffer_nr_stored (void)
 +{
 +  return kbd_fetch_ptr == kbd_store_ptr
 +    ? 0
 +    : (kbd_fetch_ptr < kbd_store_ptr
 +       ? kbd_store_ptr - kbd_fetch_ptr
 +       : ((kbd_buffer + KBD_BUFFER_SIZE) - kbd_fetch_ptr
 +          + (kbd_store_ptr - kbd_buffer)));
 +}
 +#endif	/* Store an event obtained at interrupt level into kbd_buffer, fifo */
 +
 +void
 +kbd_buffer_store_event (register struct input_event *event)
 +{
 +  kbd_buffer_store_event_hold (event, 0);
 +}
 +
 +/* Store EVENT obtained at interrupt level into kbd_buffer, fifo.
 +
 +   If HOLD_QUIT is 0, just stuff EVENT into the fifo.
 +   Else, if HOLD_QUIT.kind != NO_EVENT, discard EVENT.
 +   Else, if EVENT is a quit event, store the quit event
 +   in HOLD_QUIT, and return (thus ignoring further events).
 +
 +   This is used to postpone the processing of the quit event until all
 +   subsequent input events have been parsed (and discarded).  */
 +
 +void
 +kbd_buffer_store_event_hold (register struct input_event *event,
 +			     struct input_event *hold_quit)
 +{
 +  if (event->kind == NO_EVENT)
 +    emacs_abort ();
 +
 +  if (hold_quit && hold_quit->kind != NO_EVENT)
 +    return;
 +
 +  if (event->kind == ASCII_KEYSTROKE_EVENT)
 +    {
 +      register int c = event->code & 0377;
 +
 +      if (event->modifiers & ctrl_modifier)
 +	c = make_ctrl_char (c);
 +
 +      c |= (event->modifiers
 +	    & (meta_modifier | alt_modifier
 +	       | hyper_modifier | super_modifier));
 +
 +      if (c == quit_char)
 +	{
 +	  KBOARD *kb = FRAME_KBOARD (XFRAME (event->frame_or_window));
 +	  struct input_event *sp;
 +
 +	  if (single_kboard && kb != current_kboard)
 +	    {
 +	      kset_kbd_queue
 +		(kb, list2 (make_lispy_switch_frame (event->frame_or_window),
 +			    make_number (c)));
 +	      kb->kbd_queue_has_data = 1;
 +	      for (sp = kbd_fetch_ptr; sp != kbd_store_ptr; sp++)
 +		{
 +		  if (sp == kbd_buffer + KBD_BUFFER_SIZE)
 +		    sp = kbd_buffer;
 +
 +		  if (event_to_kboard (sp) == kb)
 +		    {
 +		      sp->kind = NO_EVENT;
 +		      sp->frame_or_window = Qnil;
 +		      sp->arg = Qnil;
 +		    }
 +		}
 +	      return;
 +	    }
 +
 +	  if (hold_quit)
 +	    {
 +	      *hold_quit = *event;
 +	      return;
 +	    }
 +
 +	  /* If this results in a quit_char being returned to Emacs as
 +	     input, set Vlast_event_frame properly.  If this doesn't
 +	     get returned to Emacs as an event, the next event read
 +	     will set Vlast_event_frame again, so this is safe to do.  */
 +	  {
 +	    Lisp_Object focus;
 +
 +	    focus = FRAME_FOCUS_FRAME (XFRAME (event->frame_or_window));
 +	    if (NILP (focus))
 +	      focus = event->frame_or_window;
 +	    internal_last_event_frame = focus;
 +	    Vlast_event_frame = focus;
 +	  }
 +
 +	  handle_interrupt (0);
 +	  return;
 +	}
 +
 +      if (c && c == stop_character)
 +	{
 +	  sys_suspend ();
 +	  return;
 +	}
 +    }
 +  /* Don't insert two BUFFER_SWITCH_EVENT's in a row.
 +     Just ignore the second one.  */
 +  else if (event->kind == BUFFER_SWITCH_EVENT
 +	   && kbd_fetch_ptr != kbd_store_ptr
 +	   && ((kbd_store_ptr == kbd_buffer
 +		? kbd_buffer + KBD_BUFFER_SIZE - 1
 +		: kbd_store_ptr - 1)->kind) == BUFFER_SWITCH_EVENT)
 +    return;
 +
 +  if (kbd_store_ptr - kbd_buffer == KBD_BUFFER_SIZE)
 +    kbd_store_ptr = kbd_buffer;
 +
 +  /* Don't let the very last slot in the buffer become full,
 +     since that would make the two pointers equal,
 +     and that is indistinguishable from an empty buffer.
 +     Discard the event if it would fill the last slot.  */
 +  if (kbd_fetch_ptr - 1 != kbd_store_ptr)
 +    {
 +      *kbd_store_ptr = *event;
 +      ++kbd_store_ptr;
 +#ifdef subprocesses
 +      if (kbd_buffer_nr_stored () > KBD_BUFFER_SIZE / 2
 +	  && ! kbd_on_hold_p ())
 +        {
 +          /* Don't read keyboard input until we have processed kbd_buffer.
 +             This happens when pasting text longer than KBD_BUFFER_SIZE/2.  */
 +          hold_keyboard_input ();
 +          if (!noninteractive)
 +            ignore_sigio ();
 +          stop_polling ();
 +        }
 +#endif	/* subprocesses */
 +    }
 +
 +  /* If we're inside while-no-input, and this event qualifies
 +     as input, set quit-flag to cause an interrupt.  */
 +  if (!NILP (Vthrow_on_input)
 +      && event->kind != FOCUS_IN_EVENT
 +      && event->kind != FOCUS_OUT_EVENT
 +      && event->kind != HELP_EVENT
 +      && event->kind != ICONIFY_EVENT
 +      && event->kind != DEICONIFY_EVENT)
 +    {
 +      Vquit_flag = Vthrow_on_input;
 +      /* If we're inside a function that wants immediate quits,
 +	 do it now.  */
 +      if (immediate_quit && NILP (Vinhibit_quit))
 +	{
 +	  immediate_quit = 0;
 +	  QUIT;
 +	}
 +    }
 +}
 +
 +
 +/* Put an input event back in the head of the event queue.  */
 +
 +void
 +kbd_buffer_unget_event (register struct input_event *event)
 +{
 +  if (kbd_fetch_ptr == kbd_buffer)
 +    kbd_fetch_ptr = kbd_buffer + KBD_BUFFER_SIZE;
 +
 +  /* Don't let the very last slot in the buffer become full,  */
 +  if (kbd_fetch_ptr - 1 != kbd_store_ptr)
 +    {
 +      --kbd_fetch_ptr;
 +      *kbd_fetch_ptr = *event;
 +    }
 +}
 +
 +/* Limit help event positions to this range, to avoid overflow problems.  */
 +#define INPUT_EVENT_POS_MAX \
 +  ((ptrdiff_t) min (PTRDIFF_MAX, min (TYPE_MAXIMUM (Time) / 2, \
 +				      MOST_POSITIVE_FIXNUM)))
 +#define INPUT_EVENT_POS_MIN (-1 - INPUT_EVENT_POS_MAX)
 +
 +/* Return a Time that encodes position POS.  POS must be in range.  */
 +
 +static Time
 +position_to_Time (ptrdiff_t pos)
 +{
 +  eassert (INPUT_EVENT_POS_MIN <= pos && pos <= INPUT_EVENT_POS_MAX);
 +  return pos;
 +}
 +
 +/* Return the position that ENCODED_POS encodes.
 +   Avoid signed integer overflow.  */
 +
 +static ptrdiff_t
 +Time_to_position (Time encoded_pos)
 +{
 +  if (encoded_pos <= INPUT_EVENT_POS_MAX)
 +    return encoded_pos;
 +  Time encoded_pos_min = INPUT_EVENT_POS_MIN;
 +  eassert (encoded_pos_min <= encoded_pos);
 +  ptrdiff_t notpos = -1 - encoded_pos;
 +  return -1 - notpos;
 +}
 +
 +/* Generate a HELP_EVENT input_event and store it in the keyboard
 +   buffer.
 +
 +   HELP is the help form.
 +
 +   FRAME and WINDOW are the frame and window where the help is
 +   generated.  OBJECT is the Lisp object where the help was found (a
 +   buffer, a string, an overlay, or nil if neither from a string nor
 +   from a buffer).  POS is the position within OBJECT where the help
 +   was found.  */
 +
 +void
 +gen_help_event (Lisp_Object help, Lisp_Object frame, Lisp_Object window,
 +		Lisp_Object object, ptrdiff_t pos)
 +{
 +  struct input_event event;
 +
 +  event.kind = HELP_EVENT;
 +  event.frame_or_window = frame;
 +  event.arg = object;
 +  event.x = WINDOWP (window) ? window : frame;
 +  event.y = help;
 +  event.timestamp = position_to_Time (pos);
 +  kbd_buffer_store_event (&event);
 +}
 +
 +
 +/* Store HELP_EVENTs for HELP on FRAME in the input queue.  */
 +
 +void
 +kbd_buffer_store_help_event (Lisp_Object frame, Lisp_Object help)
 +{
 +  struct input_event event;
 +
 +  event.kind = HELP_EVENT;
 +  event.frame_or_window = frame;
 +  event.arg = Qnil;
 +  event.x = Qnil;
 +  event.y = help;
 +  event.timestamp = 0;
 +  kbd_buffer_store_event (&event);
 +}
 +
 +
 +/* Discard any mouse events in the event buffer by setting them to
 +   NO_EVENT.  */
 +void
 +discard_mouse_events (void)
 +{
 +  struct input_event *sp;
 +  for (sp = kbd_fetch_ptr; sp != kbd_store_ptr; sp++)
 +    {
 +      if (sp == kbd_buffer + KBD_BUFFER_SIZE)
 +	sp = kbd_buffer;
 +
 +      if (sp->kind == MOUSE_CLICK_EVENT
 +	  || sp->kind == WHEEL_EVENT
 +          || sp->kind == HORIZ_WHEEL_EVENT
 +#ifdef HAVE_GPM
 +	  || sp->kind == GPM_CLICK_EVENT
 +#endif
 +	  || sp->kind == SCROLL_BAR_CLICK_EVENT
 +	  || sp->kind == HORIZONTAL_SCROLL_BAR_CLICK_EVENT)
 +	{
 +	  sp->kind = NO_EVENT;
 +	}
 +    }
 +}
 +
 +
 +/* Return true if there are any real events waiting in the event
 +   buffer, not counting `NO_EVENT's.
 +
 +   Discard NO_EVENT events at the front of the input queue, possibly
 +   leaving the input queue empty if there are no real input events.  */
 +
 +bool
 +kbd_buffer_events_waiting (void)
 +{
 +  struct input_event *sp;
 +
 +  for (sp = kbd_fetch_ptr;
 +       sp != kbd_store_ptr && sp->kind == NO_EVENT;
 +       ++sp)
 +    {
 +      if (sp == kbd_buffer + KBD_BUFFER_SIZE)
 +	sp = kbd_buffer;
 +    }
 +
 +  kbd_fetch_ptr = sp;
 +  return sp != kbd_store_ptr && sp->kind != NO_EVENT;
 +}
 +
 +
 +/* Clear input event EVENT.  */
 +
 +static void
 +clear_event (struct input_event *event)
 +{
 +  event->kind = NO_EVENT;
 +}
 +
 +
 +/* Read one event from the event buffer, waiting if necessary.
 +   The value is a Lisp object representing the event.
 +   The value is nil for an event that should be ignored,
 +   or that was handled here.
 +   We always read and discard one event.  */
 +
 +static Lisp_Object
 +kbd_buffer_get_event (KBOARD **kbp,
 +                      bool *used_mouse_menu,
 +                      struct timespec *end_time)
 +{
 +  Lisp_Object obj;
 +
 +#ifdef subprocesses
 +  if (kbd_on_hold_p () && kbd_buffer_nr_stored () < KBD_BUFFER_SIZE / 4)
 +    {
 +      /* Start reading input again because we have processed enough to
 +         be able to accept new events again.  */
 +      unhold_keyboard_input ();
 +      start_polling ();
 +    }
 +#endif	/* subprocesses */
 +
 +#if !defined HAVE_DBUS && !defined USE_FILE_NOTIFY
 +  if (noninteractive
 +      /* In case we are running as a daemon, only do this before
 +	 detaching from the terminal.  */
 +      || (IS_DAEMON && DAEMON_RUNNING))
 +    {
 +      int c = getchar ();
 +      XSETINT (obj, c);
 +      *kbp = current_kboard;
 +      return obj;
 +    }
 +#endif	/* !defined HAVE_DBUS && !defined USE_FILE_NOTIFY  */
 +
 +  /* Wait until there is input available.  */
 +  for (;;)
 +    {
 +      /* Break loop if there's an unread command event.  Needed in
 +	 moused window autoselection which uses a timer to insert such
 +	 events.  */
 +      if (CONSP (Vunread_command_events))
 +	break;
 +
 +      if (kbd_fetch_ptr != kbd_store_ptr)
 +	break;
 +      if (!NILP (do_mouse_tracking) && some_mouse_moved ())
 +	break;
 +
 +      /* If the quit flag is set, then read_char will return
 +	 quit_char, so that counts as "available input."  */
 +      if (!NILP (Vquit_flag))
 +	quit_throw_to_read_char (0);
 +
 +      /* One way or another, wait until input is available; then, if
 +	 interrupt handlers have not read it, read it now.  */
 +
 +#ifdef USABLE_SIGIO
 +      gobble_input ();
 +#endif
 +      if (kbd_fetch_ptr != kbd_store_ptr)
 +	break;
 +      if (!NILP (do_mouse_tracking) && some_mouse_moved ())
 +	break;
 +      if (end_time)
 +	{
 +	  struct timespec now = current_timespec ();
 +	  if (timespec_cmp (*end_time, now) <= 0)
 +	    return Qnil;	/* Finished waiting.  */
 +	  else
 +	    {
 +	      struct timespec duration = timespec_sub (*end_time, now);
 +	      wait_reading_process_output (min (duration.tv_sec,
 +						WAIT_READING_MAX),
 +					   duration.tv_nsec,
 +					   -1, 1, Qnil, NULL, 0);
 +	    }
 +	}
 +      else
 +	{
 +	  bool do_display = true;
 +
 +	  if (FRAME_TERMCAP_P (SELECTED_FRAME ()))
 +	    {
 +	      struct tty_display_info *tty = CURTTY ();
 +
 +	      /* When this TTY is displaying a menu, we must prevent
 +		 any redisplay, because we modify the frame's glyph
 +		 matrix behind the back of the display engine.  */
 +	      if (tty->showing_menu)
 +		do_display = false;
 +	    }
 +
 +	  wait_reading_process_output (0, 0, -1, do_display, Qnil, NULL, 0);
 +	}
 +
 +      if (!interrupt_input && kbd_fetch_ptr == kbd_store_ptr)
 +	gobble_input ();
 +    }
 +
 +  if (CONSP (Vunread_command_events))
 +    {
 +      Lisp_Object first;
 +      first = XCAR (Vunread_command_events);
 +      Vunread_command_events = XCDR (Vunread_command_events);
 +      *kbp = current_kboard;
 +      return first;
 +    }
 +
 +  /* At this point, we know that there is a readable event available
 +     somewhere.  If the event queue is empty, then there must be a
 +     mouse movement enabled and available.  */
 +  if (kbd_fetch_ptr != kbd_store_ptr)
 +    {
 +      struct input_event *event;
 +
 +      event = ((kbd_fetch_ptr < kbd_buffer + KBD_BUFFER_SIZE)
 +	       ? kbd_fetch_ptr
 +	       : kbd_buffer);
 +
 +      *kbp = event_to_kboard (event);
 +      if (*kbp == 0)
 +	*kbp = current_kboard;  /* Better than returning null ptr?  */
 +
 +      obj = Qnil;
 +
 +      /* These two kinds of events get special handling
 +	 and don't actually appear to the command loop.
 +	 We return nil for them.  */
 +      if (event->kind == SELECTION_REQUEST_EVENT
 +	  || event->kind == SELECTION_CLEAR_EVENT)
 +	{
 +#ifdef HAVE_X11
 +	  struct input_event copy;
 +
 +	  /* Remove it from the buffer before processing it,
 +	     since otherwise swallow_events will see it
 +	     and process it again.  */
 +	  copy = *event;
 +	  kbd_fetch_ptr = event + 1;
 +	  input_pending = readable_events (0);
 +	  x_handle_selection_event (©);
 +#else
 +	  /* We're getting selection request events, but we don't have
 +             a window system.  */
 +	  emacs_abort ();
 +#endif
 +	}
 +
 +#if defined (HAVE_NS)
 +      else if (event->kind == NS_TEXT_EVENT)
 +        {
 +          if (event->code == KEY_NS_PUT_WORKING_TEXT)
 +            obj = list1 (intern ("ns-put-working-text"));
 +          else
 +            obj = list1 (intern ("ns-unput-working-text"));
 +	  kbd_fetch_ptr = event + 1;
 +          if (used_mouse_menu)
 +            *used_mouse_menu = 1;
 +        }
 +#endif
 +
 +#if defined (HAVE_X11) || defined (HAVE_NTGUI) \
 +    || defined (HAVE_NS)
 +      else if (event->kind == DELETE_WINDOW_EVENT)
 +	{
 +	  /* Make an event (delete-frame (FRAME)).  */
 +	  obj = list2 (Qdelete_frame, list1 (event->frame_or_window));
 +	  kbd_fetch_ptr = event + 1;
 +	}
 +#endif
 +#if defined (HAVE_X11) || defined (HAVE_NTGUI) \
 +    || defined (HAVE_NS)
 +      else if (event->kind == ICONIFY_EVENT)
 +	{
 +	  /* Make an event (iconify-frame (FRAME)).  */
 +	  obj = list2 (Qiconify_frame, list1 (event->frame_or_window));
 +	  kbd_fetch_ptr = event + 1;
 +	}
 +      else if (event->kind == DEICONIFY_EVENT)
 +	{
 +	  /* Make an event (make-frame-visible (FRAME)).  */
 +	  obj = list2 (Qmake_frame_visible, list1 (event->frame_or_window));
 +	  kbd_fetch_ptr = event + 1;
 +	}
 +#endif
 +      else if (event->kind == BUFFER_SWITCH_EVENT)
 +	{
 +	  /* The value doesn't matter here; only the type is tested.  */
 +	  XSETBUFFER (obj, current_buffer);
 +	  kbd_fetch_ptr = event + 1;
 +	}
 +#if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \
 +    || defined (HAVE_NS) || defined (USE_GTK)
 +      else if (event->kind == MENU_BAR_ACTIVATE_EVENT)
 +	{
 +	  kbd_fetch_ptr = event + 1;
 +	  input_pending = readable_events (0);
 +	  if (FRAME_LIVE_P (XFRAME (event->frame_or_window)))
 +	    x_activate_menubar (XFRAME (event->frame_or_window));
 +	}
 +#endif
 +#ifdef HAVE_NTGUI
 +      else if (event->kind == LANGUAGE_CHANGE_EVENT)
 +	{
 +	  /* Make an event (language-change FRAME CODEPAGE LANGUAGE-ID).  */
 +	  obj = list4 (Qlanguage_change,
 +		       event->frame_or_window,
 +		       make_number (event->code),
 +		       make_number (event->modifiers));
 +	  kbd_fetch_ptr = event + 1;
 +	}
 +#endif
 +#ifdef USE_FILE_NOTIFY
 +      else if (event->kind == FILE_NOTIFY_EVENT)
 +	{
 +#ifdef HAVE_W32NOTIFY
 +	  /* Make an event (file-notify (DESCRIPTOR ACTION FILE) CALLBACK).  */
 +	  obj = list3 (Qfile_notify, event->arg, event->frame_or_window);
 +#else
 +          obj = make_lispy_event (event);
 +#endif
 +	  kbd_fetch_ptr = event + 1;
 +	}
 +#endif /* USE_FILE_NOTIFY */
 +      else if (event->kind == SAVE_SESSION_EVENT)
 +        {
 +          obj = list2 (Qsave_session, event->arg);
 +	  kbd_fetch_ptr = event + 1;
 +        }
 +      /* Just discard these, by returning nil.
 +	 With MULTI_KBOARD, these events are used as placeholders
 +	 when we need to randomly delete events from the queue.
 +	 (They shouldn't otherwise be found in the buffer,
 +	 but on some machines it appears they do show up
 +	 even without MULTI_KBOARD.)  */
 +      /* On Windows NT/9X, NO_EVENT is used to delete extraneous
 +         mouse events during a popup-menu call.  */
 +      else if (event->kind == NO_EVENT)
 +	kbd_fetch_ptr = event + 1;
 +      else if (event->kind == HELP_EVENT)
 +	{
 +	  Lisp_Object object, position, help, frame, window;
 +
 +	  frame = event->frame_or_window;
 +	  object = event->arg;
 +	  position = make_number (Time_to_position (event->timestamp));
 +	  window = event->x;
 +	  help = event->y;
 +	  clear_event (event);
 +
 +	  kbd_fetch_ptr = event + 1;
 +	  if (!WINDOWP (window))
 +	    window = Qnil;
 +	  obj = Fcons (Qhelp_echo,
 +		       list5 (frame, help, window, object, position));
 +	}
 +      else if (event->kind == FOCUS_IN_EVENT)
 +	{
 +	  /* Notification of a FocusIn event.  The frame receiving the
 +	     focus is in event->frame_or_window.  Generate a
 +	     switch-frame event if necessary.  */
 +	  Lisp_Object frame, focus;
 +
 +          frame = event->frame_or_window;
 +          focus = FRAME_FOCUS_FRAME (XFRAME (frame));
 +          if (FRAMEP (focus))
 +            frame = focus;
 +
 +          if (
 +#ifdef HAVE_X11
 +              ! NILP (event->arg)
 +              &&
 +#endif
 +              !EQ (frame, internal_last_event_frame)
 +              && !EQ (frame, selected_frame))
 +            obj = make_lispy_switch_frame (frame);
 +          else
 +            obj = make_lispy_focus_in (frame);
 +
 +          internal_last_event_frame = frame;
 +          kbd_fetch_ptr = event + 1;
 +        }
 +      else if (event->kind == FOCUS_OUT_EVENT)
 +        {
 +#ifdef HAVE_WINDOW_SYSTEM
 +
 +          Display_Info *di;
 +          Lisp_Object frame = event->frame_or_window;
 +          bool focused = false;
 +
 +          for (di = x_display_list; di && ! focused; di = di->next)
 +            focused = di->x_highlight_frame != 0;
 +
 +          if (!focused)
 +	    obj = make_lispy_focus_out (frame);
 +
 +#endif /* HAVE_WINDOW_SYSTEM */
 +
 +          kbd_fetch_ptr = event + 1;
 +        }
 +#ifdef HAVE_DBUS
 +      else if (event->kind == DBUS_EVENT)
 +	{
 +	  obj = make_lispy_event (event);
 +	  kbd_fetch_ptr = event + 1;
 +	}
 +#endif
 +      else if (event->kind == CONFIG_CHANGED_EVENT)
 +	{
 +	  obj = make_lispy_event (event);
 +	  kbd_fetch_ptr = event + 1;
 +	}
 +      else
 +	{
 +	  /* If this event is on a different frame, return a switch-frame this
 +	     time, and leave the event in the queue for next time.  */
 +	  Lisp_Object frame;
 +	  Lisp_Object focus;
 +
 +	  frame = event->frame_or_window;
 +	  if (CONSP (frame))
 +	    frame = XCAR (frame);
 +	  else if (WINDOWP (frame))
 +	    frame = WINDOW_FRAME (XWINDOW (frame));
 +
 +	  focus = FRAME_FOCUS_FRAME (XFRAME (frame));
 +	  if (! NILP (focus))
 +	    frame = focus;
 +
 +	  if (! EQ (frame, internal_last_event_frame)
 +	      && !EQ (frame, selected_frame))
 +	    obj = make_lispy_switch_frame (frame);
 +	  internal_last_event_frame = frame;
 +
 +	  /* If we didn't decide to make a switch-frame event, go ahead
 +	     and build a real event from the queue entry.  */
 +
 +	  if (NILP (obj))
 +	    {
 +	      obj = make_lispy_event (event);
 +
 +#if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \
 +    || defined (HAVE_NS) || defined (USE_GTK)
 +	      /* If this was a menu selection, then set the flag to inhibit
 +		 writing to last_nonmenu_event.  Don't do this if the event
 +		 we're returning is (menu-bar), though; that indicates the
 +		 beginning of the menu sequence, and we might as well leave
 +		 that as the `event with parameters' for this selection.  */
 +	      if (used_mouse_menu
 +		  && !EQ (event->frame_or_window, event->arg)
 +		  && (event->kind == MENU_BAR_EVENT
 +		      || event->kind == TOOL_BAR_EVENT))
 +		*used_mouse_menu = 1;
 +#endif
 +#ifdef HAVE_NS
 +	      /* Certain system events are non-key events.  */
 +	      if (used_mouse_menu
 +                  && event->kind == NS_NONKEY_EVENT)
 +		*used_mouse_menu = 1;
 +#endif
 +
 +	      /* Wipe out this event, to catch bugs.  */
 +	      clear_event (event);
 +	      kbd_fetch_ptr = event + 1;
 +	    }
 +	}
 +    }
 +  /* Try generating a mouse motion event.  */
 +  else if (!NILP (do_mouse_tracking) && some_mouse_moved ())
 +    {
 +      struct frame *f = some_mouse_moved ();
 +      Lisp_Object bar_window;
 +      enum scroll_bar_part part;
 +      Lisp_Object x, y;
 +      Time t;
 +
 +      *kbp = current_kboard;
 +      /* Note that this uses F to determine which terminal to look at.
 +	 If there is no valid info, it does not store anything
 +	 so x remains nil.  */
 +      x = Qnil;
 +
 +      /* XXX Can f or mouse_position_hook be NULL here?  */
 +      if (f && FRAME_TERMINAL (f)->mouse_position_hook)
 +        (*FRAME_TERMINAL (f)->mouse_position_hook) (&f, 0, &bar_window,
 +                                                    &part, &x, &y, &t);
 +
 +      obj = Qnil;
 +
 +      /* Decide if we should generate a switch-frame event.  Don't
 +	 generate switch-frame events for motion outside of all Emacs
 +	 frames.  */
 +      if (!NILP (x) && f)
 +	{
 +	  Lisp_Object frame;
 +
 +	  frame = FRAME_FOCUS_FRAME (f);
 +	  if (NILP (frame))
 +	    XSETFRAME (frame, f);
 +
 +	  if (! EQ (frame, internal_last_event_frame)
 +	      && !EQ (frame, selected_frame))
 +	    obj = make_lispy_switch_frame (frame);
 +	  internal_last_event_frame = frame;
 +	}
 +
 +      /* If we didn't decide to make a switch-frame event, go ahead and
 +	 return a mouse-motion event.  */
 +      if (!NILP (x) && NILP (obj))
 +	obj = make_lispy_movement (f, bar_window, part, x, y, t);
 +    }
 +  else
 +    /* We were promised by the above while loop that there was
 +       something for us to read!  */
 +    emacs_abort ();
 +
 +  input_pending = readable_events (0);
 +
 +  Vlast_event_frame = internal_last_event_frame;
 +
 +  return (obj);
 +}
 +
 +/* Process any non-user-visible events (currently X selection events),
 +   without reading any user-visible events.  */
 +
 +static void
 +process_special_events (void)
 +{
 +  struct input_event *event;
 +
 +  for (event = kbd_fetch_ptr; event != kbd_store_ptr; ++event)
 +    {
 +      if (event == kbd_buffer + KBD_BUFFER_SIZE)
 +	{
 +	  event = kbd_buffer;
 +	  if (event == kbd_store_ptr)
 +	    break;
 +	}
 +
 +      /* If we find a stored X selection request, handle it now.  */
 +      if (event->kind == SELECTION_REQUEST_EVENT
 +	  || event->kind == SELECTION_CLEAR_EVENT)
 +	{
 +#ifdef HAVE_X11
 +
 +	  /* Remove the event from the fifo buffer before processing;
 +	     otherwise swallow_events called recursively could see it
 +	     and process it again.  To do this, we move the events
 +	     between kbd_fetch_ptr and EVENT one slot to the right,
 +	     cyclically.  */
 +
 +	  struct input_event copy = *event;
 +	  struct input_event *beg
 +	    = (kbd_fetch_ptr == kbd_buffer + KBD_BUFFER_SIZE)
 +	    ? kbd_buffer : kbd_fetch_ptr;
 +
 +	  if (event > beg)
 +	    memmove (beg + 1, beg, (event - beg) * sizeof (struct input_event));
 +	  else if (event < beg)
 +	    {
 +	      if (event > kbd_buffer)
 +		memmove (kbd_buffer + 1, kbd_buffer,
 +			 (event - kbd_buffer) * sizeof (struct input_event));
 +	      *kbd_buffer = *(kbd_buffer + KBD_BUFFER_SIZE - 1);
 +	      if (beg < kbd_buffer + KBD_BUFFER_SIZE - 1)
 +		memmove (beg + 1, beg,
 +			 (kbd_buffer + KBD_BUFFER_SIZE - 1 - beg)
 +			 * sizeof (struct input_event));
 +	    }
 +
 +	  if (kbd_fetch_ptr == kbd_buffer + KBD_BUFFER_SIZE)
 +	    kbd_fetch_ptr = kbd_buffer + 1;
 +	  else
 +	    kbd_fetch_ptr++;
 +
 +	  input_pending = readable_events (0);
 +	  x_handle_selection_event (©);
 +#else
 +	  /* We're getting selection request events, but we don't have
 +             a window system.  */
 +	  emacs_abort ();
 +#endif
 +	}
 +    }
 +}
 +
 +/* Process any events that are not user-visible, run timer events that
 +   are ripe, and return, without reading any user-visible events.  */
 +
 +void
 +swallow_events (bool do_display)
 +{
 +  unsigned old_timers_run;
 +
 +  process_special_events ();
 +
 +  old_timers_run = timers_run;
 +  get_input_pending (READABLE_EVENTS_DO_TIMERS_NOW);
 +
 +  if (!input_pending && timers_run != old_timers_run && do_display)
 +    redisplay_preserve_echo_area (7);
 +}
 +
 +/* Record the start of when Emacs is idle,
 +   for the sake of running idle-time timers.  */
 +
 +static void
 +timer_start_idle (void)
 +{
 +  /* If we are already in the idle state, do nothing.  */
 +  if (timespec_valid_p (timer_idleness_start_time))
 +    return;
 +
 +  timer_idleness_start_time = current_timespec ();
 +  timer_last_idleness_start_time = timer_idleness_start_time;
 +
 +  /* Mark all idle-time timers as once again candidates for running.  */
 +  call0 (intern ("internal-timer-start-idle"));
 +}
 +
 +/* Record that Emacs is no longer idle, so stop running idle-time timers.  */
 +
 +static void
 +timer_stop_idle (void)
 +{
 +  timer_idleness_start_time = invalid_timespec ();
 +}
 +
 +/* Resume idle timer from last idle start time.  */
 +
 +static void
 +timer_resume_idle (void)
 +{
 +  if (timespec_valid_p (timer_idleness_start_time))
 +    return;
 +
 +  timer_idleness_start_time = timer_last_idleness_start_time;
 +}
 +
 +/* This is only for debugging.  */
 +struct input_event last_timer_event EXTERNALLY_VISIBLE;
 +
 +/* List of elisp functions to call, delayed because they were generated in
 +   a context where Elisp could not be safely run (e.g. redisplay, signal,
 +   ...).  Each element has the form (FUN . ARGS).  */
 +Lisp_Object pending_funcalls;
 +
 +/* Return true if TIMER is a valid timer, placing its value into *RESULT.  */
 +static bool
 +decode_timer (Lisp_Object timer, struct timespec *result)
 +{
 +  Lisp_Object *vec;
 +
 +  if (! (VECTORP (timer) && ASIZE (timer) == 9))
 +    return 0;
 +  vec = XVECTOR (timer)->contents;
 +  if (! NILP (vec[0]))
 +    return 0;
 +  if (! INTEGERP (vec[2]))
 +    return false;
 +
 +  struct lisp_time t;
 +  if (decode_time_components (vec[1], vec[2], vec[3], vec[8], &t, 0) <= 0)
 +    return false;
 +  *result = lisp_to_timespec (t);
 +  return timespec_valid_p (*result);
 +}
 +
 +
 +/* Check whether a timer has fired.  To prevent larger problems we simply
 +   disregard elements that are not proper timers.  Do not make a circular
 +   timer list for the time being.
 +
 +   Returns the time to wait until the next timer fires.  If a
 +   timer is triggering now, return zero.
 +   If no timer is active, return -1.
 +
 +   If a timer is ripe, we run it, with quitting turned off.
 +   In that case we return 0 to indicate that a new timer_check_2 call
 +   should be done.  */
 +
 +static struct timespec
 +timer_check_2 (Lisp_Object timers, Lisp_Object idle_timers)
 +{
 +  struct timespec nexttime;
 +  struct timespec now;
 +  struct timespec idleness_now;
 +  Lisp_Object chosen_timer;
 +  struct gcpro gcpro1;
 +
 +  nexttime = invalid_timespec ();
 +
 +  chosen_timer = Qnil;
 +  GCPRO1 (chosen_timer);
 +
 +  /* First run the code that was delayed.  */
 +  while (CONSP (pending_funcalls))
 +    {
 +      Lisp_Object funcall = XCAR (pending_funcalls);
 +      pending_funcalls = XCDR (pending_funcalls);
 +      safe_call2 (Qapply, XCAR (funcall), XCDR (funcall));
 +    }
 +
 +  if (CONSP (timers) || CONSP (idle_timers))
 +    {
 +      now = current_timespec ();
 +      idleness_now = (timespec_valid_p (timer_idleness_start_time)
 +		      ? timespec_sub (now, timer_idleness_start_time)
 +		      : make_timespec (0, 0));
 +    }
 +
 +  while (CONSP (timers) || CONSP (idle_timers))
 +    {
 +      Lisp_Object timer = Qnil, idle_timer = Qnil;
 +      struct timespec timer_time, idle_timer_time;
 +      struct timespec difference;
 +      struct timespec timer_difference = invalid_timespec ();
 +      struct timespec idle_timer_difference = invalid_timespec ();
 +      bool ripe, timer_ripe = 0, idle_timer_ripe = 0;
 +
 +      /* Set TIMER and TIMER_DIFFERENCE
 +	 based on the next ordinary timer.
 +	 TIMER_DIFFERENCE is the distance in time from NOW to when
 +	 this timer becomes ripe.
 +         Skip past invalid timers and timers already handled.  */
 +      if (CONSP (timers))
 +	{
 +	  timer = XCAR (timers);
 +	  if (! decode_timer (timer, &timer_time))
 +	    {
 +	      timers = XCDR (timers);
 +	      continue;
 +	    }
 +
 +	  timer_ripe = timespec_cmp (timer_time, now) <= 0;
 +	  timer_difference = (timer_ripe
 +			      ? timespec_sub (now, timer_time)
 +			      : timespec_sub (timer_time, now));
 +	}
 +
 +      /* Likewise for IDLE_TIMER and IDLE_TIMER_DIFFERENCE
 +	 based on the next idle timer.  */
 +      if (CONSP (idle_timers))
 +	{
 +	  idle_timer = XCAR (idle_timers);
 +	  if (! decode_timer (idle_timer, &idle_timer_time))
 +	    {
 +	      idle_timers = XCDR (idle_timers);
 +	      continue;
 +	    }
 +
 +	  idle_timer_ripe = timespec_cmp (idle_timer_time, idleness_now) <= 0;
 +	  idle_timer_difference
 +	    = (idle_timer_ripe
 +	       ? timespec_sub (idleness_now, idle_timer_time)
 +	       : timespec_sub (idle_timer_time, idleness_now));
 +	}
 +
 +      /* Decide which timer is the next timer,
 +	 and set CHOSEN_TIMER, DIFFERENCE, and RIPE accordingly.
 +	 Also step down the list where we found that timer.  */
 +
 +      if (timespec_valid_p (timer_difference)
 +	  && (! timespec_valid_p (idle_timer_difference)
 +	      || idle_timer_ripe < timer_ripe
 +	      || (idle_timer_ripe == timer_ripe
 +		  && ((timer_ripe
 +		       ? timespec_cmp (idle_timer_difference,
 +				       timer_difference)
 +		       : timespec_cmp (timer_difference,
 +				       idle_timer_difference))
 +		      < 0))))
 +	{
 +	  chosen_timer = timer;
 +	  timers = XCDR (timers);
 +	  difference = timer_difference;
 +	  ripe = timer_ripe;
 +	}
 +      else
 +	{
 +	  chosen_timer = idle_timer;
 +	  idle_timers = XCDR (idle_timers);
 +	  difference = idle_timer_difference;
 +	  ripe = idle_timer_ripe;
 +	}
 +
 +      /* If timer is ripe, run it if it hasn't been run.  */
 +      if (ripe)
 +	{
 +	  if (NILP (AREF (chosen_timer, 0)))
 +	    {
 +	      ptrdiff_t count = SPECPDL_INDEX ();
 +	      Lisp_Object old_deactivate_mark = Vdeactivate_mark;
 +
 +	      /* Mark the timer as triggered to prevent problems if the lisp
 +		 code fails to reschedule it right.  */
 +	      ASET (chosen_timer, 0, Qt);
 +
 +	      specbind (Qinhibit_quit, Qt);
 +
 +	      call1 (Qtimer_event_handler, chosen_timer);
 +	      Vdeactivate_mark = old_deactivate_mark;
 +	      timers_run++;
 +	      unbind_to (count, Qnil);
 +
 +	      /* Since we have handled the event,
 +		 we don't need to tell the caller to wake up and do it.  */
 +              /* But the caller must still wait for the next timer, so
 +                 return 0 to indicate that.  */
 +	    }
 +
 +	  nexttime = make_timespec (0, 0);
 +          break;
 +	}
 +      else
 +	/* When we encounter a timer that is still waiting,
 +	   return the amount of time to wait before it is ripe.  */
 +	{
 +	  UNGCPRO;
 +	  return difference;
 +	}
 +    }
 +
 +  /* No timers are pending in the future.  */
 +  /* Return 0 if we generated an event, and -1 if not.  */
 +  UNGCPRO;
 +  return nexttime;
 +}
 +
 +
 +/* Check whether a timer has fired.  To prevent larger problems we simply
 +   disregard elements that are not proper timers.  Do not make a circular
 +   timer list for the time being.
 +
 +   Returns the time to wait until the next timer fires.
 +   If no timer is active, return an invalid value.
 +
 +   As long as any timer is ripe, we run it.  */
 +
 +struct timespec
 +timer_check (void)
 +{
 +  struct timespec nexttime;
 +  Lisp_Object timers, idle_timers;
 +  struct gcpro gcpro1, gcpro2;
 +
 +  Lisp_Object tem = Vinhibit_quit;
 +  Vinhibit_quit = Qt;
 +
 +  /* We use copies of the timers' lists to allow a timer to add itself
 +     again, without locking up Emacs if the newly added timer is
 +     already ripe when added.  */
 +
 +  /* Always consider the ordinary timers.  */
 +  timers = Fcopy_sequence (Vtimer_list);
 +  /* Consider the idle timers only if Emacs is idle.  */
 +  if (timespec_valid_p (timer_idleness_start_time))
 +    idle_timers = Fcopy_sequence (Vtimer_idle_list);
 +  else
 +    idle_timers = Qnil;
 +
 +  Vinhibit_quit = tem;
 +
 +  GCPRO2 (timers, idle_timers);
 +
 +  do
 +    {
 +      nexttime = timer_check_2 (timers, idle_timers);
 +    }
 +  while (nexttime.tv_sec == 0 && nexttime.tv_nsec == 0);
 +
 +  UNGCPRO;
 +  return nexttime;
 +}
 +
 +DEFUN ("current-idle-time", Fcurrent_idle_time, Scurrent_idle_time, 0, 0, 0,
 +       doc: /* Return the current length of Emacs idleness, or nil.
 +The value when Emacs is idle is a list of four integers (HIGH LOW USEC PSEC)
 +in the same style as (current-time).
 +
 +The value when Emacs is not idle is nil.
 +
 +PSEC is a multiple of the system clock resolution.  */)
 +  (void)
 +{
 +  if (timespec_valid_p (timer_idleness_start_time))
 +    return make_lisp_time (timespec_sub (current_timespec (),
 +					 timer_idleness_start_time));
 +
 +  return Qnil;
 +}
 +
 +/* Caches for modify_event_symbol.  */
 +static Lisp_Object accent_key_syms;
 +static Lisp_Object func_key_syms;
 +static Lisp_Object mouse_syms;
 +static Lisp_Object wheel_syms;
 +static Lisp_Object drag_n_drop_syms;
 +
 +/* This is a list of keysym codes for special "accent" characters.
 +   It parallels lispy_accent_keys.  */
 +
 +static const int lispy_accent_codes[] =
 +{
 +#ifdef XK_dead_circumflex
 +  XK_dead_circumflex,
 +#else
 +  0,
 +#endif
 +#ifdef XK_dead_grave
 +  XK_dead_grave,
 +#else
 +  0,
 +#endif
 +#ifdef XK_dead_tilde
 +  XK_dead_tilde,
 +#else
 +  0,
 +#endif
 +#ifdef XK_dead_diaeresis
 +  XK_dead_diaeresis,
 +#else
 +  0,
 +#endif
 +#ifdef XK_dead_macron
 +  XK_dead_macron,
 +#else
 +  0,
 +#endif
 +#ifdef XK_dead_degree
 +  XK_dead_degree,
 +#else
 +  0,
 +#endif
 +#ifdef XK_dead_acute
 +  XK_dead_acute,
 +#else
 +  0,
 +#endif
 +#ifdef XK_dead_cedilla
 +  XK_dead_cedilla,
 +#else
 +  0,
 +#endif
 +#ifdef XK_dead_breve
 +  XK_dead_breve,
 +#else
 +  0,
 +#endif
 +#ifdef XK_dead_ogonek
 +  XK_dead_ogonek,
 +#else
 +  0,
 +#endif
 +#ifdef XK_dead_caron
 +  XK_dead_caron,
 +#else
 +  0,
 +#endif
 +#ifdef XK_dead_doubleacute
 +  XK_dead_doubleacute,
 +#else
 +  0,
 +#endif
 +#ifdef XK_dead_abovedot
 +  XK_dead_abovedot,
 +#else
 +  0,
 +#endif
 +#ifdef XK_dead_abovering
 +  XK_dead_abovering,
 +#else
 +  0,
 +#endif
 +#ifdef XK_dead_iota
 +  XK_dead_iota,
 +#else
 +  0,
 +#endif
 +#ifdef XK_dead_belowdot
 +  XK_dead_belowdot,
 +#else
 +  0,
 +#endif
 +#ifdef XK_dead_voiced_sound
 +  XK_dead_voiced_sound,
 +#else
 +  0,
 +#endif
 +#ifdef XK_dead_semivoiced_sound
 +  XK_dead_semivoiced_sound,
 +#else
 +  0,
 +#endif
 +#ifdef XK_dead_hook
 +  XK_dead_hook,
 +#else
 +  0,
 +#endif
 +#ifdef XK_dead_horn
 +  XK_dead_horn,
 +#else
 +  0,
 +#endif
 +};
 +
 +/* This is a list of Lisp names for special "accent" characters.
 +   It parallels lispy_accent_codes.  */
 +
 +static const char *const lispy_accent_keys[] =
 +{
 +  "dead-circumflex",
 +  "dead-grave",
 +  "dead-tilde",
 +  "dead-diaeresis",
 +  "dead-macron",
 +  "dead-degree",
 +  "dead-acute",
 +  "dead-cedilla",
 +  "dead-breve",
 +  "dead-ogonek",
 +  "dead-caron",
 +  "dead-doubleacute",
 +  "dead-abovedot",
 +  "dead-abovering",
 +  "dead-iota",
 +  "dead-belowdot",
 +  "dead-voiced-sound",
 +  "dead-semivoiced-sound",
 +  "dead-hook",
 +  "dead-horn",
 +};
 +
 +#ifdef HAVE_NTGUI
 +#define FUNCTION_KEY_OFFSET 0x0
 +
 +const char *const lispy_function_keys[] =
 +  {
 +    0,                /* 0                      */
 +
 +    0,                /* VK_LBUTTON        0x01 */
 +    0,                /* VK_RBUTTON        0x02 */
 +    "cancel",         /* VK_CANCEL         0x03 */
 +    0,                /* VK_MBUTTON        0x04 */
 +
 +    0, 0, 0,          /*    0x05 .. 0x07        */
 +
 +    "backspace",      /* VK_BACK           0x08 */
 +    "tab",            /* VK_TAB            0x09 */
 +
 +    0, 0,             /*    0x0A .. 0x0B        */
 +
 +    "clear",          /* VK_CLEAR          0x0C */
 +    "return",         /* VK_RETURN         0x0D */
 +
 +    0, 0,             /*    0x0E .. 0x0F        */
 +
 +    0,                /* VK_SHIFT          0x10 */
 +    0,                /* VK_CONTROL        0x11 */
 +    0,                /* VK_MENU           0x12 */
 +    "pause",          /* VK_PAUSE          0x13 */
 +    "capslock",       /* VK_CAPITAL        0x14 */
 +    "kana",           /* VK_KANA/VK_HANGUL 0x15 */
 +    0,                /*    0x16                */
 +    "junja",          /* VK_JUNJA          0x17 */
 +    "final",          /* VK_FINAL          0x18 */
 +    "kanji",          /* VK_KANJI/VK_HANJA 0x19 */
 +    0,                /*    0x1A                */
 +    "escape",         /* VK_ESCAPE         0x1B */
 +    "convert",        /* VK_CONVERT        0x1C */
 +    "non-convert",    /* VK_NONCONVERT     0x1D */
 +    "accept",         /* VK_ACCEPT         0x1E */
 +    "mode-change",    /* VK_MODECHANGE     0x1F */
 +    0,                /* VK_SPACE          0x20 */
 +    "prior",          /* VK_PRIOR          0x21 */
 +    "next",           /* VK_NEXT           0x22 */
 +    "end",            /* VK_END            0x23 */
 +    "home",           /* VK_HOME           0x24 */
 +    "left",           /* VK_LEFT           0x25 */
 +    "up",             /* VK_UP             0x26 */
 +    "right",          /* VK_RIGHT          0x27 */
 +    "down",           /* VK_DOWN           0x28 */
 +    "select",         /* VK_SELECT         0x29 */
 +    "print",          /* VK_PRINT          0x2A */
 +    "execute",        /* VK_EXECUTE        0x2B */
 +    "snapshot",       /* VK_SNAPSHOT       0x2C */
 +    "insert",         /* VK_INSERT         0x2D */
 +    "delete",         /* VK_DELETE         0x2E */
 +    "help",           /* VK_HELP           0x2F */
 +
 +    /* VK_0 thru VK_9 are the same as ASCII '0' thru '9' (0x30 - 0x39) */
 +
 +    0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
 +
 +    0, 0, 0, 0, 0, 0, 0, /* 0x3A .. 0x40       */
 +
 +    /* VK_A thru VK_Z are the same as ASCII 'A' thru 'Z' (0x41 - 0x5A) */
 +
 +    0, 0, 0, 0, 0, 0, 0, 0, 0,
 +    0, 0, 0, 0, 0, 0, 0, 0, 0,
 +    0, 0, 0, 0, 0, 0, 0, 0,
 +
 +    "lwindow",       /* VK_LWIN           0x5B */
 +    "rwindow",       /* VK_RWIN           0x5C */
 +    "apps",          /* VK_APPS           0x5D */
 +    0,               /*    0x5E                */
 +    "sleep",
 +    "kp-0",          /* VK_NUMPAD0        0x60 */
 +    "kp-1",          /* VK_NUMPAD1        0x61 */
 +    "kp-2",          /* VK_NUMPAD2        0x62 */
 +    "kp-3",          /* VK_NUMPAD3        0x63 */
 +    "kp-4",          /* VK_NUMPAD4        0x64 */
 +    "kp-5",          /* VK_NUMPAD5        0x65 */
 +    "kp-6",          /* VK_NUMPAD6        0x66 */
 +    "kp-7",          /* VK_NUMPAD7        0x67 */
 +    "kp-8",          /* VK_NUMPAD8        0x68 */
 +    "kp-9",          /* VK_NUMPAD9        0x69 */
 +    "kp-multiply",   /* VK_MULTIPLY       0x6A */
 +    "kp-add",        /* VK_ADD            0x6B */
 +    "kp-separator",  /* VK_SEPARATOR      0x6C */
 +    "kp-subtract",   /* VK_SUBTRACT       0x6D */
 +    "kp-decimal",    /* VK_DECIMAL        0x6E */
 +    "kp-divide",     /* VK_DIVIDE         0x6F */
 +    "f1",            /* VK_F1             0x70 */
 +    "f2",            /* VK_F2             0x71 */
 +    "f3",            /* VK_F3             0x72 */
 +    "f4",            /* VK_F4             0x73 */
 +    "f5",            /* VK_F5             0x74 */
 +    "f6",            /* VK_F6             0x75 */
 +    "f7",            /* VK_F7             0x76 */
 +    "f8",            /* VK_F8             0x77 */
 +    "f9",            /* VK_F9             0x78 */
 +    "f10",           /* VK_F10            0x79 */
 +    "f11",           /* VK_F11            0x7A */
 +    "f12",           /* VK_F12            0x7B */
 +    "f13",           /* VK_F13            0x7C */
 +    "f14",           /* VK_F14            0x7D */
 +    "f15",           /* VK_F15            0x7E */
 +    "f16",           /* VK_F16            0x7F */
 +    "f17",           /* VK_F17            0x80 */
 +    "f18",           /* VK_F18            0x81 */
 +    "f19",           /* VK_F19            0x82 */
 +    "f20",           /* VK_F20            0x83 */
 +    "f21",           /* VK_F21            0x84 */
 +    "f22",           /* VK_F22            0x85 */
 +    "f23",           /* VK_F23            0x86 */
 +    "f24",           /* VK_F24            0x87 */
 +
 +    0, 0, 0, 0,      /*    0x88 .. 0x8B        */
 +    0, 0, 0, 0,      /*    0x8C .. 0x8F        */
 +
 +    "kp-numlock",    /* VK_NUMLOCK        0x90 */
 +    "scroll",        /* VK_SCROLL         0x91 */
 +    /* Not sure where the following block comes from.
 +       Windows headers have NEC and Fujitsu specific keys in
 +       this block, but nothing generic.  */
 +    "kp-space",	     /* VK_NUMPAD_CLEAR   0x92 */
 +    "kp-enter",	     /* VK_NUMPAD_ENTER   0x93 */
 +    "kp-prior",	     /* VK_NUMPAD_PRIOR   0x94 */
 +    "kp-next",	     /* VK_NUMPAD_NEXT    0x95 */
 +    "kp-end",	     /* VK_NUMPAD_END     0x96 */
 +    "kp-home",	     /* VK_NUMPAD_HOME    0x97 */
 +    "kp-left",	     /* VK_NUMPAD_LEFT    0x98 */
 +    "kp-up",	     /* VK_NUMPAD_UP      0x99 */
 +    "kp-right",	     /* VK_NUMPAD_RIGHT   0x9A */
 +    "kp-down",	     /* VK_NUMPAD_DOWN    0x9B */
 +    "kp-insert",     /* VK_NUMPAD_INSERT  0x9C */
 +    "kp-delete",     /* VK_NUMPAD_DELETE  0x9D */
 +
 +    0, 0,	     /*    0x9E .. 0x9F        */
 +
 +    /*
 +     * VK_L* & VK_R* - left and right Alt, Ctrl and Shift virtual keys.
 +     * Used only as parameters to GetAsyncKeyState and GetKeyState.
 +     * No other API or message will distinguish left and right keys this way.
 +     * 0xA0 .. 0xA5
 +     */
 +    0, 0, 0, 0, 0, 0,
 +
 +    /* Multimedia keys. These are handled as WM_APPCOMMAND, which allows us
 +       to enable them selectively, and gives access to a few more functions.
 +       See lispy_multimedia_keys below.  */
 +    0, 0, 0, 0, 0, 0, 0, /* 0xA6 .. 0xAC        Browser */
 +    0, 0, 0,             /* 0xAD .. 0xAF         Volume */
 +    0, 0, 0, 0,          /* 0xB0 .. 0xB3          Media */
 +    0, 0, 0, 0,          /* 0xB4 .. 0xB7           Apps */
 +
 +    /* 0xB8 .. 0xC0 "OEM" keys - all seem to be punctuation.  */
 +    0, 0, 0, 0, 0, 0, 0, 0, 0,
 +
 +    /* 0xC1 - 0xDA unallocated, 0xDB-0xDF more OEM keys */
 +    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
 +    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
 +
 +    0,               /* 0xE0                   */
 +    "ax",            /* VK_OEM_AX         0xE1 */
 +    0,               /* VK_OEM_102        0xE2 */
 +    "ico-help",      /* VK_ICO_HELP       0xE3 */
 +    "ico-00",        /* VK_ICO_00         0xE4 */
 +    0,               /* VK_PROCESSKEY     0xE5 - used by IME */
 +    "ico-clear",     /* VK_ICO_CLEAR      0xE6 */
 +    0,               /* VK_PACKET         0xE7  - used to pass Unicode chars */
 +    0,               /*                   0xE8 */
 +    "reset",         /* VK_OEM_RESET      0xE9 */
 +    "jump",          /* VK_OEM_JUMP       0xEA */
 +    "oem-pa1",       /* VK_OEM_PA1        0xEB */
 +    "oem-pa2",       /* VK_OEM_PA2        0xEC */
 +    "oem-pa3",       /* VK_OEM_PA3        0xED */
 +    "wsctrl",        /* VK_OEM_WSCTRL     0xEE */
 +    "cusel",         /* VK_OEM_CUSEL      0xEF */
 +    "oem-attn",      /* VK_OEM_ATTN       0xF0 */
 +    "finish",        /* VK_OEM_FINISH     0xF1 */
 +    "copy",          /* VK_OEM_COPY       0xF2 */
 +    "auto",          /* VK_OEM_AUTO       0xF3 */
 +    "enlw",          /* VK_OEM_ENLW       0xF4 */
 +    "backtab",       /* VK_OEM_BACKTAB    0xF5 */
 +    "attn",          /* VK_ATTN           0xF6 */
 +    "crsel",         /* VK_CRSEL          0xF7 */
 +    "exsel",         /* VK_EXSEL          0xF8 */
 +    "ereof",         /* VK_EREOF          0xF9 */
 +    "play",          /* VK_PLAY           0xFA */
 +    "zoom",          /* VK_ZOOM           0xFB */
 +    "noname",        /* VK_NONAME         0xFC */
 +    "pa1",           /* VK_PA1            0xFD */
 +    "oem_clear",     /* VK_OEM_CLEAR      0xFE */
 +    0 /* 0xFF */
 +  };
 +
 +/* Some of these duplicate the "Media keys" on newer keyboards,
 +   but they are delivered to the application in a different way.  */
 +static const char *const lispy_multimedia_keys[] =
 +  {
 +    0,
 +    "browser-back",
 +    "browser-forward",
 +    "browser-refresh",
 +    "browser-stop",
 +    "browser-search",
 +    "browser-favorites",
 +    "browser-home",
 +    "volume-mute",
 +    "volume-down",
 +    "volume-up",
 +    "media-next",
 +    "media-previous",
 +    "media-stop",
 +    "media-play-pause",
 +    "mail",
 +    "media-select",
 +    "app-1",
 +    "app-2",
 +    "bass-down",
 +    "bass-boost",
 +    "bass-up",
 +    "treble-down",
 +    "treble-up",
 +    "mic-volume-mute",
 +    "mic-volume-down",
 +    "mic-volume-up",
 +    "help",
 +    "find",
 +    "new",
 +    "open",
 +    "close",
 +    "save",
 +    "print",
 +    "undo",
 +    "redo",
 +    "copy",
 +    "cut",
 +    "paste",
 +    "mail-reply",
 +    "mail-forward",
 +    "mail-send",
 +    "spell-check",
 +    "toggle-dictate-command",
 +    "mic-toggle",
 +    "correction-list",
 +    "media-play",
 +    "media-pause",
 +    "media-record",
 +    "media-fast-forward",
 +    "media-rewind",
 +    "media-channel-up",
 +    "media-channel-down"
 +  };
 +
 +#else /* not HAVE_NTGUI */
 +
 +/* This should be dealt with in XTread_socket now, and that doesn't
 +   depend on the client system having the Kana syms defined.  See also
 +   the XK_kana_A case below.  */
 +#if 0
 +#ifdef XK_kana_A
 +static const char *const lispy_kana_keys[] =
 +  {
 +    /* X Keysym value */
 +    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,	/* 0x400 .. 0x40f */
 +    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,	/* 0x410 .. 0x41f */
 +    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,	/* 0x420 .. 0x42f */
 +    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,	/* 0x430 .. 0x43f */
 +    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,	/* 0x440 .. 0x44f */
 +    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,	/* 0x450 .. 0x45f */
 +    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,	/* 0x460 .. 0x46f */
 +    0,0,0,0,0,0,0,0,0,0,0,0,0,0,"overline",0,
 +    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,	/* 0x480 .. 0x48f */
 +    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,	/* 0x490 .. 0x49f */
 +    0, "kana-fullstop", "kana-openingbracket", "kana-closingbracket",
 +    "kana-comma", "kana-conjunctive", "kana-WO", "kana-a",
 +    "kana-i", "kana-u", "kana-e", "kana-o",
 +    "kana-ya", "kana-yu", "kana-yo", "kana-tsu",
 +    "prolongedsound", "kana-A", "kana-I", "kana-U",
 +    "kana-E", "kana-O", "kana-KA", "kana-KI",
 +    "kana-KU", "kana-KE", "kana-KO", "kana-SA",
 +    "kana-SHI", "kana-SU", "kana-SE", "kana-SO",
 +    "kana-TA", "kana-CHI", "kana-TSU", "kana-TE",
 +    "kana-TO", "kana-NA", "kana-NI", "kana-NU",
 +    "kana-NE", "kana-NO", "kana-HA", "kana-HI",
 +    "kana-FU", "kana-HE", "kana-HO", "kana-MA",
 +    "kana-MI", "kana-MU", "kana-ME", "kana-MO",
 +    "kana-YA", "kana-YU", "kana-YO", "kana-RA",
 +    "kana-RI", "kana-RU", "kana-RE", "kana-RO",
 +    "kana-WA", "kana-N", "voicedsound", "semivoicedsound",
 +    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,	/* 0x4e0 .. 0x4ef */
 +    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,	/* 0x4f0 .. 0x4ff */
 +  };
 +#endif /* XK_kana_A */
 +#endif /* 0 */
 +
 +#define FUNCTION_KEY_OFFSET 0xff00
 +
 +/* You'll notice that this table is arranged to be conveniently
 +   indexed by X Windows keysym values.  */
 +static const char *const lispy_function_keys[] =
 +  {
 +    /* X Keysym value */
 +
 +    0, 0, 0, 0, 0, 0, 0, 0,			      /* 0xff00...0f */
 +    "backspace", "tab", "linefeed", "clear",
 +    0, "return", 0, 0,
 +    0, 0, 0, "pause",				      /* 0xff10...1f */
 +    0, 0, 0, 0, 0, 0, 0, "escape",
 +    0, 0, 0, 0,
 +    0, "kanji", "muhenkan", "henkan",		      /* 0xff20...2f */
 +    "romaji", "hiragana", "katakana", "hiragana-katakana",
 +    "zenkaku", "hankaku", "zenkaku-hankaku", "touroku",
 +    "massyo", "kana-lock", "kana-shift", "eisu-shift",
 +    "eisu-toggle",				      /* 0xff30...3f */
 +       0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
 +    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,   /* 0xff40...4f */
 +
 +    "home", "left", "up", "right", /* 0xff50 */	/* IsCursorKey */
 +    "down", "prior", "next", "end",
 +    "begin", 0, 0, 0, 0, 0, 0, 0,
 +    "select",			/* 0xff60 */	/* IsMiscFunctionKey */
 +    "print",
 +    "execute",
 +    "insert",
 +    0,		/* 0xff64 */
 +    "undo",
 +    "redo",
 +    "menu",
 +    "find",
 +    "cancel",
 +    "help",
 +    "break",			/* 0xff6b */
 +
 +    0, 0, 0, 0,
 +    0, 0, 0, 0, "backtab", 0, 0, 0,		/* 0xff70...  */
 +    0, 0, 0, 0, 0, 0, 0, "kp-numlock",		/* 0xff78...  */
 +    "kp-space",			/* 0xff80 */	/* IsKeypadKey */
 +    0, 0, 0, 0, 0, 0, 0, 0,
 +    "kp-tab",			/* 0xff89 */
 +    0, 0, 0,
 +    "kp-enter",			/* 0xff8d */
 +    0, 0, 0,
 +    "kp-f1",			/* 0xff91 */
 +    "kp-f2",
 +    "kp-f3",
 +    "kp-f4",
 +    "kp-home",			/* 0xff95 */
 +    "kp-left",
 +    "kp-up",
 +    "kp-right",
 +    "kp-down",
 +    "kp-prior",			/* kp-page-up */
 +    "kp-next",			/* kp-page-down */
 +    "kp-end",
 +    "kp-begin",
 +    "kp-insert",
 +    "kp-delete",
 +    0,				/* 0xffa0 */
 +    0, 0, 0, 0, 0, 0, 0, 0, 0,
 +    "kp-multiply",		/* 0xffaa */
 +    "kp-add",
 +    "kp-separator",
 +    "kp-subtract",
 +    "kp-decimal",
 +    "kp-divide",		/* 0xffaf */
 +    "kp-0",			/* 0xffb0 */
 +    "kp-1",	"kp-2",	"kp-3",	"kp-4",	"kp-5",	"kp-6",	"kp-7",	"kp-8",	"kp-9",
 +    0,		/* 0xffba */
 +    0, 0,
 +    "kp-equal",			/* 0xffbd */
 +    "f1",			/* 0xffbe */	/* IsFunctionKey */
 +    "f2",
 +    "f3", "f4", "f5", "f6", "f7", "f8",	"f9", "f10", /* 0xffc0 */
 +    "f11", "f12", "f13", "f14", "f15", "f16", "f17", "f18",
 +    "f19", "f20", "f21", "f22", "f23", "f24", "f25", "f26", /* 0xffd0 */
 +    "f27", "f28", "f29", "f30", "f31", "f32", "f33", "f34",
 +    "f35", 0, 0, 0, 0, 0, 0, 0,	/* 0xffe0 */
 +    0, 0, 0, 0, 0, 0, 0, 0,
 +    0, 0, 0, 0, 0, 0, 0, 0,     /* 0xfff0 */
 +    0, 0, 0, 0, 0, 0, 0, "delete"
 +  };
 +
 +/* ISO 9995 Function and Modifier Keys; the first byte is 0xFE.  */
 +#define ISO_FUNCTION_KEY_OFFSET 0xfe00
 +
 +static const char *const iso_lispy_function_keys[] =
 +  {
 +    0, 0, 0, 0, 0, 0, 0, 0,	/* 0xfe00 */
 +    0, 0, 0, 0, 0, 0, 0, 0,	/* 0xfe08 */
 +    0, 0, 0, 0, 0, 0, 0, 0,	/* 0xfe10 */
 +    0, 0, 0, 0, 0, 0, 0, 0,	/* 0xfe18 */
 +    "iso-lefttab",		/* 0xfe20 */
 +    "iso-move-line-up", "iso-move-line-down",
 +    "iso-partial-line-up", "iso-partial-line-down",
 +    "iso-partial-space-left", "iso-partial-space-right",
 +    "iso-set-margin-left", "iso-set-margin-right", /* 0xffe27, 28 */
 +    "iso-release-margin-left", "iso-release-margin-right",
 +    "iso-release-both-margins",
 +    "iso-fast-cursor-left", "iso-fast-cursor-right",
 +    "iso-fast-cursor-up", "iso-fast-cursor-down",
 +    "iso-continuous-underline", "iso-discontinuous-underline", /* 0xfe30, 31 */
 +    "iso-emphasize", "iso-center-object", "iso-enter", /* ... 0xfe34 */
 +  };
 +
 +#endif /* not HAVE_NTGUI */
 +
 +static Lisp_Object Vlispy_mouse_stem;
 +
 +static const char *const lispy_wheel_names[] =
 +{
 +  "wheel-up", "wheel-down", "wheel-left", "wheel-right"
 +};
 +
 +/* drag-n-drop events are generated when a set of selected files are
 +   dragged from another application and dropped onto an Emacs window.  */
 +static const char *const lispy_drag_n_drop_names[] =
 +{
 +  "drag-n-drop"
 +};
 +
 +/* An array of symbol indexes of scroll bar parts, indexed by an enum
 +   scroll_bar_part value.  Note that Qnil corresponds to
 +   scroll_bar_nowhere and should not appear in Lisp events.  */
 +static short const scroll_bar_parts[] = {
 +  SYMBOL_INDEX (Qnil), SYMBOL_INDEX (Qabove_handle), SYMBOL_INDEX (Qhandle),
 +  SYMBOL_INDEX (Qbelow_handle), SYMBOL_INDEX (Qup), SYMBOL_INDEX (Qdown),
 +  SYMBOL_INDEX (Qtop), SYMBOL_INDEX (Qbottom), SYMBOL_INDEX (Qend_scroll),
 +  SYMBOL_INDEX (Qratio), SYMBOL_INDEX (Qbefore_handle),
 +  SYMBOL_INDEX (Qhorizontal_handle), SYMBOL_INDEX (Qafter_handle),
 +  SYMBOL_INDEX (Qleft), SYMBOL_INDEX (Qright), SYMBOL_INDEX (Qleftmost),
 +  SYMBOL_INDEX (Qrightmost), SYMBOL_INDEX (Qend_scroll), SYMBOL_INDEX (Qratio)
 +};
 +
 +/* A vector, indexed by button number, giving the down-going location
 +   of currently depressed buttons, both scroll bar and non-scroll bar.
 +
 +   The elements have the form
 +     (BUTTON-NUMBER MODIFIER-MASK . REST)
 +   where REST is the cdr of a position as it would be reported in the event.
 +
 +   The make_lispy_event function stores positions here to tell the
 +   difference between click and drag events, and to store the starting
 +   location to be included in drag events.  */
 +
 +static Lisp_Object button_down_location;
 +
 +/* Information about the most recent up-going button event:  Which
 +   button, what location, and what time.  */
 +
 +static int last_mouse_button;
 +static int last_mouse_x;
 +static int last_mouse_y;
 +static Time button_down_time;
 +
 +/* The number of clicks in this multiple-click.  */
 +
 +static int double_click_count;
 +
 +/* X and Y are frame-relative coordinates for a click or wheel event.
 +   Return a Lisp-style event list.  */
 +
 +static Lisp_Object
 +make_lispy_position (struct frame *f, Lisp_Object x, Lisp_Object y,
 +		     Time t)
 +{
 +  enum window_part part;
 +  Lisp_Object posn = Qnil;
 +  Lisp_Object extra_info = Qnil;
 +  /* Coordinate pixel positions to return.  */
 +  int xret = 0, yret = 0;
 +  /* The window under frame pixel coordinates (x,y)  */
 +  Lisp_Object window = f
 +    ? window_from_coordinates (f, XINT (x), XINT (y), &part, 0)
 +    : Qnil;
 +
 +  if (WINDOWP (window))
 +    {
 +      /* It's a click in window WINDOW at frame coordinates (X,Y)  */
 +      struct window *w = XWINDOW (window);
 +      Lisp_Object string_info = Qnil;
 +      ptrdiff_t textpos = 0;
 +      int col = -1, row = -1;
 +      int dx  = -1, dy  = -1;
 +      int width = -1, height = -1;
 +      Lisp_Object object = Qnil;
 +
 +      /* Pixel coordinates relative to the window corner.  */
 +      int wx = XINT (x) - WINDOW_LEFT_EDGE_X (w);
 +      int wy = XINT (y) - WINDOW_TOP_EDGE_Y (w);
 +
 +      /* For text area clicks, return X, Y relative to the corner of
 +	 this text area.  Note that dX, dY etc are set below, by
 +	 buffer_posn_from_coords.  */
 +      if (part == ON_TEXT)
 +	{
 +	  xret = XINT (x) - window_box_left (w, TEXT_AREA);
 +	  yret = wy - WINDOW_HEADER_LINE_HEIGHT (w);
 +	}
 +      /* For mode line and header line clicks, return X, Y relative to
 +	 the left window edge.  Use mode_line_string to look for a
 +	 string on the click position.  */
 +      else if (part == ON_MODE_LINE || part == ON_HEADER_LINE)
 +	{
 +	  Lisp_Object string;
 +	  ptrdiff_t charpos;
 +
 +	  posn = (part == ON_MODE_LINE) ? Qmode_line : Qheader_line;
 +	  /* Note that mode_line_string takes COL, ROW as pixels and
 +	     converts them to characters.  */
 +	  col = wx;
 +	  row = wy;
 +	  string = mode_line_string (w, part, &col, &row, &charpos,
 +				     &object, &dx, &dy, &width, &height);
 +	  if (STRINGP (string))
 +	    string_info = Fcons (string, make_number (charpos));
 +	  textpos = -1;
 +
 +	  xret = wx;
 +	  yret = wy;
 +	}
 +      /* For fringes and margins, Y is relative to the area's (and the
 +	 window's) top edge, while X is meaningless.  */
 +      else if (part == ON_LEFT_MARGIN || part == ON_RIGHT_MARGIN)
 +	{
 +	  Lisp_Object string;
 +	  ptrdiff_t charpos;
 +
 +	  posn = (part == ON_LEFT_MARGIN) ? Qleft_margin : Qright_margin;
 +	  col = wx;
 +	  row = wy;
 +	  string = marginal_area_string (w, part, &col, &row, &charpos,
 +					 &object, &dx, &dy, &width, &height);
 +	  if (STRINGP (string))
 +	    string_info = Fcons (string, make_number (charpos));
 +	  xret = wx;
 +	  yret = wy - WINDOW_HEADER_LINE_HEIGHT (w);
 +	}
 +      else if (part == ON_LEFT_FRINGE)
 +	{
 +	  posn = Qleft_fringe;
 +	  col = 0;
 +	  xret = wx;
 +	  dx = wx
 +	    - (WINDOW_HAS_FRINGES_OUTSIDE_MARGINS (w)
 +	       ? 0 : window_box_width (w, LEFT_MARGIN_AREA));
 +	  dy = yret = wy - WINDOW_HEADER_LINE_HEIGHT (w);
 +	}
 +      else if (part == ON_RIGHT_FRINGE)
 +	{
 +	  posn = Qright_fringe;
 +	  col = 0;
 +	  xret = wx;
 +	  dx = wx
 +	    - window_box_width (w, LEFT_MARGIN_AREA)
 +	    - window_box_width (w, TEXT_AREA)
 +	    - (WINDOW_HAS_FRINGES_OUTSIDE_MARGINS (w)
 +	       ? window_box_width (w, RIGHT_MARGIN_AREA)
 +	       : 0);
 +	  dy = yret = wy - WINDOW_HEADER_LINE_HEIGHT (w);
 +	}
 +      else if (part == ON_VERTICAL_BORDER)
 +	{
 +	  posn = Qvertical_line;
 +	  width = 1;
 +	  dx = 0;
 +	  xret = wx;
 +	  dy = yret = wy;
 +	}
 +      else if (part == ON_VERTICAL_SCROLL_BAR)
 +	{
 +	  posn = Qvertical_scroll_bar;
 +	  width = WINDOW_SCROLL_BAR_AREA_WIDTH (w);
 +	  dx = xret = wx;
 +	  dy = yret = wy;
 +	}
 +      else if (part == ON_HORIZONTAL_SCROLL_BAR)
 +	{
 +	  posn = Qhorizontal_scroll_bar;
 +	  width = WINDOW_SCROLL_BAR_AREA_HEIGHT (w);
 +	  dx = xret = wx;
 +	  dy = yret = wy;
 +	}
 +      else if (part == ON_RIGHT_DIVIDER)
 +	{
 +	  posn = Qright_divider;
 +	  width = WINDOW_RIGHT_DIVIDER_WIDTH (w);
 +	  dx = xret = wx;
 +	  dy = yret = wy;
 +	}
 +      else if (part == ON_BOTTOM_DIVIDER)
 +	{
 +	  posn = Qbottom_divider;
 +	  width = WINDOW_BOTTOM_DIVIDER_WIDTH (w);
 +	  dx = xret = wx;
 +	  dy = yret = wy;
 +	}
 +
 +      /* For clicks in the text area, fringes, margins, or vertical
 +	 scroll bar, call buffer_posn_from_coords to extract TEXTPOS,
 +	 the buffer position nearest to the click.  */
 +      if (!textpos)
 +	{
 +	  Lisp_Object string2, object2 = Qnil;
 +	  struct display_pos p;
 +	  int dx2, dy2;
 +	  int width2, height2;
 +	  /* The pixel X coordinate passed to buffer_posn_from_coords
 +	     is the X coordinate relative to the text area for clicks
 +	     in text-area, right-margin/fringe and right-side vertical
 +	     scroll bar, zero otherwise.  */
 +	  int x2
 +	    = (part == ON_TEXT) ? xret
 +	    : (part == ON_RIGHT_FRINGE || part == ON_RIGHT_MARGIN
 +	       || (part == ON_VERTICAL_SCROLL_BAR
 +		   && WINDOW_HAS_VERTICAL_SCROLL_BAR_ON_RIGHT (w)))
 +	    ? (XINT (x) - window_box_left (w, TEXT_AREA))
 +	    : 0;
 +	  int y2 = wy;
 +
 +	  string2 = buffer_posn_from_coords (w, &x2, &y2, &p,
 +					     &object2, &dx2, &dy2,
 +					     &width2, &height2);
 +	  textpos = CHARPOS (p.pos);
 +	  if (col < 0) col = x2;
 +	  if (row < 0) row = y2;
 +	  if (dx < 0) dx = dx2;
 +	  if (dy < 0) dy = dy2;
 +	  if (width < 0) width = width2;
 +	  if (height < 0) height = height2;
 +
 +	  if (NILP (posn))
 +	    {
 +	      posn = make_number (textpos);
 +	      if (STRINGP (string2))
 +		string_info = Fcons (string2,
 +				     make_number (CHARPOS (p.string_pos)));
 +	    }
 +	  if (NILP (object))
 +	    object = object2;
 +	}
 +
 +#ifdef HAVE_WINDOW_SYSTEM
 +      if (IMAGEP (object))
 +	{
 +	  Lisp_Object image_map, hotspot;
 +	  if ((image_map = Fplist_get (XCDR (object), QCmap),
 +	       !NILP (image_map))
 +	      && (hotspot = find_hot_spot (image_map, dx, dy),
 +		  CONSP (hotspot))
 +	      && (hotspot = XCDR (hotspot), CONSP (hotspot)))
 +	    posn = XCAR (hotspot);
 +	}
 +#endif
 +
 +      /* Object info.  */
 +      extra_info
 +	= list3 (object,
 +		 Fcons (make_number (dx), make_number (dy)),
 +		 Fcons (make_number (width), make_number (height)));
 +
 +      /* String info.  */
 +      extra_info = Fcons (string_info,
 +			  Fcons (textpos < 0 ? Qnil : make_number (textpos),
 +				 Fcons (Fcons (make_number (col),
 +					       make_number (row)),
 +					extra_info)));
 +    }
 +  else if (f != 0)
 +    {
 +      /* Return mouse pixel coordinates here.  */
 +      XSETFRAME (window, f);
 +      xret = XINT (x);
 +      yret = XINT (y);
 +    }
 +  else
 +    window = Qnil;
 +
 +  return Fcons (window,
 +		Fcons (posn,
 +		       Fcons (Fcons (make_number (xret),
 +				     make_number (yret)),
 +			      Fcons (make_number (t),
 +				     extra_info))));
 +}
 +
 +/* Return non-zero if F is a GUI frame that uses some toolkit-managed
 +   menu bar.  This really means that Emacs draws and manages the menu
 +   bar as part of its normal display, and therefore can compute its
 +   geometry.  */
 +static bool
 +toolkit_menubar_in_use (struct frame *f)
 +{
 +#if defined (USE_X_TOOLKIT) || defined (USE_GTK) || defined (HAVE_NS) || defined (HAVE_NTGUI)
 +  return !(!FRAME_WINDOW_P (f));
 +#else
 +  return false;
 +#endif
 +}
 +
 +/* Build the part of Lisp event which represents scroll bar state from
 +   EV.  TYPE is one of Qvertical_scroll_bar or Qhorizontal_scroll_bar.  */
 +
 +static Lisp_Object
 +make_scroll_bar_position (struct input_event *ev, Lisp_Object type)
 +{
 +  return list5 (ev->frame_or_window, type, Fcons (ev->x, ev->y),
 +		make_number (ev->timestamp),
 +		builtin_lisp_symbol (scroll_bar_parts[ev->part]));
 +}
 +
 +/* Given a struct input_event, build the lisp event which represents
 +   it.  If EVENT is 0, build a mouse movement event from the mouse
 +   movement buffer, which should have a movement event in it.
 +
 +   Note that events must be passed to this function in the order they
 +   are received; this function stores the location of button presses
 +   in order to build drag events when the button is released.  */
 +
 +static Lisp_Object
 +make_lispy_event (struct input_event *event)
 +{
 +  int i;
 +
 +  switch (event->kind)
 +    {
 +      /* A simple keystroke.  */
 +    case ASCII_KEYSTROKE_EVENT:
 +    case MULTIBYTE_CHAR_KEYSTROKE_EVENT:
 +      {
 +	Lisp_Object lispy_c;
 +	EMACS_INT c = event->code;
 +	if (event->kind == ASCII_KEYSTROKE_EVENT)
 +	  {
 +	    c &= 0377;
 +	    eassert (c == event->code);
 +	    /* Turn ASCII characters into control characters
 +	       when proper.  */
 +	    if (event->modifiers & ctrl_modifier)
 +	      {
 +		c = make_ctrl_char (c);
 +		event->modifiers &= ~ctrl_modifier;
 +	      }
 +	  }
 +
 +	/* Add in the other modifier bits.  The shift key was taken care
 +	   of by the X code.  */
 +	c |= (event->modifiers
 +	      & (meta_modifier | alt_modifier
 +		 | hyper_modifier | super_modifier | ctrl_modifier));
 +	/* Distinguish Shift-SPC from SPC.  */
 +	if ((event->code) == 040
 +	    && event->modifiers & shift_modifier)
 +	  c |= shift_modifier;
 +	button_down_time = 0;
 +	XSETFASTINT (lispy_c, c);
 +	return lispy_c;
 +      }
 +
 +#ifdef HAVE_NS
 +      /* NS_NONKEY_EVENTs are just like NON_ASCII_KEYSTROKE_EVENTs,
 +	 except that they are non-key events (last-nonmenu-event is nil).  */
 +    case NS_NONKEY_EVENT:
 +#endif
 +
 +      /* A function key.  The symbol may need to have modifier prefixes
 +	 tacked onto it.  */
 +    case NON_ASCII_KEYSTROKE_EVENT:
 +      button_down_time = 0;
 +
 +      for (i = 0; i < ARRAYELTS (lispy_accent_codes); i++)
 +	if (event->code == lispy_accent_codes[i])
 +	  return modify_event_symbol (i,
 +				      event->modifiers,
 +				      Qfunction_key, Qnil,
 +				      lispy_accent_keys, &accent_key_syms,
 +                                      ARRAYELTS (lispy_accent_keys));
 +
 +#if 0
 +#ifdef XK_kana_A
 +      if (event->code >= 0x400 && event->code < 0x500)
 +	return modify_event_symbol (event->code - 0x400,
 +				    event->modifiers & ~shift_modifier,
 +				    Qfunction_key, Qnil,
 +				    lispy_kana_keys, &func_key_syms,
 +                                    ARRAYELTS (lispy_kana_keys));
 +#endif /* XK_kana_A */
 +#endif /* 0 */
 +
 +#ifdef ISO_FUNCTION_KEY_OFFSET
 +      if (event->code < FUNCTION_KEY_OFFSET
 +	  && event->code >= ISO_FUNCTION_KEY_OFFSET)
 +	return modify_event_symbol (event->code - ISO_FUNCTION_KEY_OFFSET,
 +				    event->modifiers,
 +				    Qfunction_key, Qnil,
 +				    iso_lispy_function_keys, &func_key_syms,
 +                                    ARRAYELTS (iso_lispy_function_keys));
 +#endif
 +
 +      if ((FUNCTION_KEY_OFFSET <= event->code
 +	   && (event->code
 +	       < FUNCTION_KEY_OFFSET + ARRAYELTS (lispy_function_keys)))
 +	  && lispy_function_keys[event->code - FUNCTION_KEY_OFFSET])
 +	return modify_event_symbol (event->code - FUNCTION_KEY_OFFSET,
 +				    event->modifiers,
 +				    Qfunction_key, Qnil,
 +				    lispy_function_keys, &func_key_syms,
 +				    ARRAYELTS (lispy_function_keys));
 +
 +      /* Handle system-specific or unknown keysyms.
 +	 We need to use an alist rather than a vector as the cache
 +	 since we can't make a vector long enough.  */
 +      if (NILP (KVAR (current_kboard, system_key_syms)))
 +	kset_system_key_syms (current_kboard, Fcons (Qnil, Qnil));
 +      return modify_event_symbol (event->code,
 +				  event->modifiers,
 +				  Qfunction_key,
 +				  KVAR (current_kboard, Vsystem_key_alist),
 +				  0, &KVAR (current_kboard, system_key_syms),
 +				  PTRDIFF_MAX);
 +
 +#ifdef HAVE_NTGUI
 +    case MULTIMEDIA_KEY_EVENT:
 +      if (event->code < ARRAYELTS (lispy_multimedia_keys)
 +          && event->code > 0 && lispy_multimedia_keys[event->code])
 +        {
 +          return modify_event_symbol (event->code, event->modifiers,
 +                                      Qfunction_key, Qnil,
 +                                      lispy_multimedia_keys, &func_key_syms,
 +                                      ARRAYELTS (lispy_multimedia_keys));
 +        }
 +      return Qnil;
 +#endif
 +
 +      /* A mouse click.  Figure out where it is, decide whether it's
 +         a press, click or drag, and build the appropriate structure.  */
 +    case MOUSE_CLICK_EVENT:
 +#ifdef HAVE_GPM
 +    case GPM_CLICK_EVENT:
 +#endif
 +#ifndef USE_TOOLKIT_SCROLL_BARS
 +    case SCROLL_BAR_CLICK_EVENT:
 +    case HORIZONTAL_SCROLL_BAR_CLICK_EVENT:
 +#endif
 +      {
 +	int button = event->code;
 +	bool is_double;
 +	Lisp_Object position;
 +	Lisp_Object *start_pos_ptr;
 +	Lisp_Object start_pos;
 +
 +	position = Qnil;
 +
 +	/* Build the position as appropriate for this mouse click.  */
 +	if (event->kind == MOUSE_CLICK_EVENT
 +#ifdef HAVE_GPM
 +	    || event->kind == GPM_CLICK_EVENT
 +#endif
 +	    )
 +	  {
 +	    struct frame *f = XFRAME (event->frame_or_window);
 +	    int row, column;
 +
 +	    /* Ignore mouse events that were made on frame that
 +	       have been deleted.  */
 +	    if (! FRAME_LIVE_P (f))
 +	      return Qnil;
 +
 +	    /* EVENT->x and EVENT->y are frame-relative pixel
 +	       coordinates at this place.  Under old redisplay, COLUMN
 +	       and ROW are set to frame relative glyph coordinates
 +	       which are then used to determine whether this click is
 +	       in a menu (non-toolkit version).  */
 +	    if (!toolkit_menubar_in_use (f))
 +	      {
 +		pixel_to_glyph_coords (f, XINT (event->x), XINT (event->y),
 +				       &column, &row, NULL, 1);
 +
 +		/* In the non-toolkit version, clicks on the menu bar
 +		   are ordinary button events in the event buffer.
 +		   Distinguish them, and invoke the menu.
 +
 +		   (In the toolkit version, the toolkit handles the
 +		   menu bar and Emacs doesn't know about it until
 +		   after the user makes a selection.)  */
 +		if (row >= 0 && row < FRAME_MENU_BAR_LINES (f)
 +		  && (event->modifiers & down_modifier))
 +		  {
 +		    Lisp_Object items, item;
 +
 +		    /* Find the menu bar item under `column'.  */
 +		    item = Qnil;
 +		    items = FRAME_MENU_BAR_ITEMS (f);
 +		    for (i = 0; i < ASIZE (items); i += 4)
 +		      {
 +			Lisp_Object pos, string;
 +			string = AREF (items, i + 1);
 +			pos = AREF (items, i + 3);
 +			if (NILP (string))
 +			  break;
 +			if (column >= XINT (pos)
 +			    && column < XINT (pos) + SCHARS (string))
 +			  {
 +			    item = AREF (items, i);
 +			    break;
 +			  }
 +		      }
 +
 +		    /* ELisp manual 2.4b says (x y) are window
 +		       relative but code says they are
 +		       frame-relative.  */
 +		    position = list4 (event->frame_or_window,
 +				      Qmenu_bar,
 +				      Fcons (event->x, event->y),
 +				      make_number (event->timestamp));
 +
 +		    return list2 (item, position);
 +		  }
 +	      }
 +
 +	    position = make_lispy_position (f, event->x, event->y,
 +					    event->timestamp);
 +	  }
 +#ifndef USE_TOOLKIT_SCROLL_BARS
 +	else
 +	  /* It's a scrollbar click.  */
 +	  position = make_scroll_bar_position (event, Qvertical_scroll_bar);
 +#endif /* not USE_TOOLKIT_SCROLL_BARS */
 +
 +	if (button >= ASIZE (button_down_location))
 +	  {
 +	    ptrdiff_t incr = button - ASIZE (button_down_location) + 1;
 +	    button_down_location = larger_vector (button_down_location,
 +						  incr, -1);
 +	    mouse_syms = larger_vector (mouse_syms, incr, -1);
 +	  }
 +
 +	start_pos_ptr = aref_addr (button_down_location, button);
 +	start_pos = *start_pos_ptr;
 +	*start_pos_ptr = Qnil;
 +
 +	{
 +	  /* On window-system frames, use the value of
 +	     double-click-fuzz as is.  On other frames, interpret it
 +	     as a multiple of 1/8 characters.  */
 +	  struct frame *f;
 +	  int fuzz;
 +
 +	  if (WINDOWP (event->frame_or_window))
 +	    f = XFRAME (XWINDOW (event->frame_or_window)->frame);
 +	  else if (FRAMEP (event->frame_or_window))
 +	    f = XFRAME (event->frame_or_window);
 +	  else
 +	    emacs_abort ();
 +
 +	  if (FRAME_WINDOW_P (f))
 +	    fuzz = double_click_fuzz;
 +	  else
 +	    fuzz = double_click_fuzz / 8;
 +
 +	  is_double = (button == last_mouse_button
 +		       && (eabs (XINT (event->x) - last_mouse_x) <= fuzz)
 +		       && (eabs (XINT (event->y) - last_mouse_y) <= fuzz)
 +		       && button_down_time != 0
 +		       && (EQ (Vdouble_click_time, Qt)
 +			   || (NATNUMP (Vdouble_click_time)
 +			       && (event->timestamp - button_down_time
 +				   < XFASTINT (Vdouble_click_time)))));
 +	}
 +
 +	last_mouse_button = button;
 +	last_mouse_x = XINT (event->x);
 +	last_mouse_y = XINT (event->y);
 +
 +	/* If this is a button press, squirrel away the location, so
 +           we can decide later whether it was a click or a drag.  */
 +	if (event->modifiers & down_modifier)
 +	  {
 +	    if (is_double)
 +	      {
 +		double_click_count++;
 +		event->modifiers |= ((double_click_count > 2)
 +				     ? triple_modifier
 +				     : double_modifier);
 +	      }
 +	    else
 +	      double_click_count = 1;
 +	    button_down_time = event->timestamp;
 +	    *start_pos_ptr = Fcopy_alist (position);
 +	    ignore_mouse_drag_p = 0;
 +	  }
 +
 +	/* Now we're releasing a button - check the co-ordinates to
 +           see if this was a click or a drag.  */
 +	else if (event->modifiers & up_modifier)
 +	  {
 +	    /* If we did not see a down before this up, ignore the up.
 +	       Probably this happened because the down event chose a
 +	       menu item.  It would be an annoyance to treat the
 +	       release of the button that chose the menu item as a
 +	       separate event.  */
 +
 +	    if (!CONSP (start_pos))
 +	      return Qnil;
 +
 +	    event->modifiers &= ~up_modifier;
 +
 +	      {
 +		Lisp_Object new_down, down;
 +		EMACS_INT xdiff = double_click_fuzz, ydiff = double_click_fuzz;
 +
 +		/* The third element of every position
 +		   should be the (x,y) pair.  */
 +		down = Fcar (Fcdr (Fcdr (start_pos)));
 +		new_down = Fcar (Fcdr (Fcdr (position)));
 +
 +		if (CONSP (down)
 +		    && INTEGERP (XCAR (down)) && INTEGERP (XCDR (down)))
 +		  {
 +		    xdiff = XINT (XCAR (new_down)) - XINT (XCAR (down));
 +		    ydiff = XINT (XCDR (new_down)) - XINT (XCDR (down));
 +		  }
 +
 +		if (ignore_mouse_drag_p)
 +		  {
 +		    event->modifiers |= click_modifier;
 +		    ignore_mouse_drag_p = 0;
 +		  }
 +		else if (xdiff < double_click_fuzz && xdiff > - double_click_fuzz
 +			 && ydiff < double_click_fuzz && ydiff > - double_click_fuzz
 +		  /* Maybe the mouse has moved a lot, caused scrolling, and
 +		     eventually ended up at the same screen position (but
 +		     not buffer position) in which case it is a drag, not
 +		     a click.  */
 +		    /* FIXME: OTOH if the buffer position has changed
 +		       because of a timer or process filter rather than
 +		       because of mouse movement, it should be considered as
 +		       a click.  But mouse-drag-region completely ignores
 +		       this case and it hasn't caused any real problem, so
 +		       it's probably OK to ignore it as well.  */
 +		    && EQ (Fcar (Fcdr (start_pos)), Fcar (Fcdr (position))))
 +		  /* Mouse hasn't moved (much).  */
 +		  event->modifiers |= click_modifier;
 +		else
 +		  {
 +		    button_down_time = 0;
 +		    event->modifiers |= drag_modifier;
 +		  }
 +
 +		/* Don't check is_double; treat this as multiple
 +		   if the down-event was multiple.  */
 +		if (double_click_count > 1)
 +		  event->modifiers |= ((double_click_count > 2)
 +				       ? triple_modifier
 +				       : double_modifier);
 +	      }
 +	  }
 +	else
 +	  /* Every mouse event should either have the down_modifier or
 +             the up_modifier set.  */
 +	  emacs_abort ();
 +
 +	{
 +	  /* Get the symbol we should use for the mouse click.  */
 +	  Lisp_Object head;
 +
 +	  head = modify_event_symbol (button,
 +				      event->modifiers,
 +				      Qmouse_click, Vlispy_mouse_stem,
 +				      NULL,
 +				      &mouse_syms,
 +				      ASIZE (mouse_syms));
 +	  if (event->modifiers & drag_modifier)
 +	    return list3 (head, start_pos, position);
 +	  else if (event->modifiers & (double_modifier | triple_modifier))
 +	    return list3 (head, position, make_number (double_click_count));
 +	  else
 +	    return list2 (head, position);
 +	}
 +      }
 +
 +    case WHEEL_EVENT:
 +    case HORIZ_WHEEL_EVENT:
 +      {
 +	Lisp_Object position;
 +	Lisp_Object head;
 +
 +	/* Build the position as appropriate for this mouse click.  */
 +	struct frame *f = XFRAME (event->frame_or_window);
 +
 +	/* Ignore wheel events that were made on frame that have been
 +	   deleted.  */
 +	if (! FRAME_LIVE_P (f))
 +	  return Qnil;
 +
 +	position = make_lispy_position (f, event->x, event->y,
 +					event->timestamp);
 +
 +	/* Set double or triple modifiers to indicate the wheel speed.  */
 +	{
 +	  /* On window-system frames, use the value of
 +	     double-click-fuzz as is.  On other frames, interpret it
 +	     as a multiple of 1/8 characters.  */
 +	  struct frame *fr;
 +	  int fuzz;
 +	  int symbol_num;
 +	  bool is_double;
 +
 +	  if (WINDOWP (event->frame_or_window))
 +	    fr = XFRAME (XWINDOW (event->frame_or_window)->frame);
 +	  else if (FRAMEP (event->frame_or_window))
 +	    fr = XFRAME (event->frame_or_window);
 +	  else
 +	    emacs_abort ();
 +
 +	  fuzz = FRAME_WINDOW_P (fr)
 +	    ? double_click_fuzz : double_click_fuzz / 8;
 +
 +	  if (event->modifiers & up_modifier)
 +	    {
 +	      /* Emit a wheel-up event.  */
 +	      event->modifiers &= ~up_modifier;
 +	      symbol_num = 0;
 +	    }
 +	  else if (event->modifiers & down_modifier)
 +	    {
 +	      /* Emit a wheel-down event.  */
 +	      event->modifiers &= ~down_modifier;
 +	      symbol_num = 1;
 +	    }
 +	  else
 +	    /* Every wheel event should either have the down_modifier or
 +	       the up_modifier set.  */
 +	    emacs_abort ();
 +
 +          if (event->kind == HORIZ_WHEEL_EVENT)
 +            symbol_num += 2;
 +
 +	  is_double = (last_mouse_button == - (1 + symbol_num)
 +		       && (eabs (XINT (event->x) - last_mouse_x) <= fuzz)
 +		       && (eabs (XINT (event->y) - last_mouse_y) <= fuzz)
 +		       && button_down_time != 0
 +		       && (EQ (Vdouble_click_time, Qt)
 +			   || (NATNUMP (Vdouble_click_time)
 +			       && (event->timestamp - button_down_time
 +				   < XFASTINT (Vdouble_click_time)))));
 +	  if (is_double)
 +	    {
 +	      double_click_count++;
 +	      event->modifiers |= ((double_click_count > 2)
 +				   ? triple_modifier
 +				   : double_modifier);
 +	    }
 +	  else
 +	    {
 +	      double_click_count = 1;
 +	      event->modifiers |= click_modifier;
 +	    }
 +
 +	  button_down_time = event->timestamp;
 +	  /* Use a negative value to distinguish wheel from mouse button.  */
 +	  last_mouse_button = - (1 + symbol_num);
 +	  last_mouse_x = XINT (event->x);
 +	  last_mouse_y = XINT (event->y);
 +
 +	  /* Get the symbol we should use for the wheel event.  */
 +	  head = modify_event_symbol (symbol_num,
 +				      event->modifiers,
 +				      Qmouse_click,
 +				      Qnil,
 +				      lispy_wheel_names,
 +				      &wheel_syms,
 +				      ASIZE (wheel_syms));
 +	}
 +
 +	if (event->modifiers & (double_modifier | triple_modifier))
 +	  return list3 (head, position, make_number (double_click_count));
 +	else
 +	  return list2 (head, position);
 +      }
 +
 +
 +#ifdef USE_TOOLKIT_SCROLL_BARS
 +
 +      /* We don't have down and up events if using toolkit scroll bars,
 +	 so make this always a click event.  Store in the `part' of
 +	 the Lisp event a symbol which maps to the following actions:
 +
 +	 `above_handle'		page up
 +	 `below_handle'		page down
 +	 `up'			line up
 +	 `down'			line down
 +	 `top'			top of buffer
 +	 `bottom'		bottom of buffer
 +	 `handle'		thumb has been dragged.
 +	 `end-scroll'		end of interaction with scroll bar
 +
 +	 The incoming input_event contains in its `part' member an
 +	 index of type `enum scroll_bar_part' which we can use as an
 +	 index in scroll_bar_parts to get the appropriate symbol.  */
 +
 +    case SCROLL_BAR_CLICK_EVENT:
 +      {
 +	Lisp_Object position, head;
 +
 +	position = make_scroll_bar_position (event, Qvertical_scroll_bar);
 +
 +	/* Always treat scroll bar events as clicks.  */
 +	event->modifiers |= click_modifier;
 +	event->modifiers &= ~up_modifier;
 +
 +	if (event->code >= ASIZE (mouse_syms))
 +          mouse_syms = larger_vector (mouse_syms,
 +				      event->code - ASIZE (mouse_syms) + 1,
 +				      -1);
 +
 +	/* Get the symbol we should use for the mouse click.  */
 +	head = modify_event_symbol (event->code,
 +				    event->modifiers,
 +				    Qmouse_click,
 +				    Vlispy_mouse_stem,
 +				    NULL, &mouse_syms,
 +				    ASIZE (mouse_syms));
 +	return list2 (head, position);
 +      }
 +
 +    case HORIZONTAL_SCROLL_BAR_CLICK_EVENT:
 +      {
 +	Lisp_Object position, head;
 +
 +	position = make_scroll_bar_position (event, Qhorizontal_scroll_bar);
 +
 +	/* Always treat scroll bar events as clicks.  */
 +	event->modifiers |= click_modifier;
 +	event->modifiers &= ~up_modifier;
 +
 +	if (event->code >= ASIZE (mouse_syms))
 +          mouse_syms = larger_vector (mouse_syms,
 +				      event->code - ASIZE (mouse_syms) + 1,
 +				      -1);
 +
 +	/* Get the symbol we should use for the mouse click.  */
 +	head = modify_event_symbol (event->code,
 +				    event->modifiers,
 +				    Qmouse_click,
 +				    Vlispy_mouse_stem,
 +				    NULL, &mouse_syms,
 +				    ASIZE (mouse_syms));
 +	return list2 (head, position);
 +      }
 +
 +#endif /* USE_TOOLKIT_SCROLL_BARS */
 +
 +    case DRAG_N_DROP_EVENT:
 +      {
 +	struct frame *f;
 +	Lisp_Object head, position;
 +	Lisp_Object files;
 +
 +	f = XFRAME (event->frame_or_window);
 +	files = event->arg;
 +
 +	/* Ignore mouse events that were made on frames that
 +	   have been deleted.  */
 +	if (! FRAME_LIVE_P (f))
 +	  return Qnil;
 +
 +	position = make_lispy_position (f, event->x, event->y,
 +					event->timestamp);
 +
 +	head = modify_event_symbol (0, event->modifiers,
 +				    Qdrag_n_drop, Qnil,
 +				    lispy_drag_n_drop_names,
 +				    &drag_n_drop_syms, 1);
 +	return list3 (head, position, files);
 +      }
 +
 +#if defined (USE_X_TOOLKIT) || defined (HAVE_NTGUI) \
 +    || defined (HAVE_NS) || defined (USE_GTK)
 +    case MENU_BAR_EVENT:
 +      if (EQ (event->arg, event->frame_or_window))
 +	/* This is the prefix key.  We translate this to
 +	   `(menu_bar)' because the code in keyboard.c for menu
 +	   events, which we use, relies on this.  */
 +	return list1 (Qmenu_bar);
 +      return event->arg;
 +#endif
 +
 +    case SELECT_WINDOW_EVENT:
 +      /* Make an event (select-window (WINDOW)).  */
 +      return list2 (Qselect_window, list1 (event->frame_or_window));
 +
 +    case TOOL_BAR_EVENT:
 +      if (EQ (event->arg, event->frame_or_window))
 +	/* This is the prefix key.  We translate this to
 +	   `(tool_bar)' because the code in keyboard.c for tool bar
 +	   events, which we use, relies on this.  */
 +	return list1 (Qtool_bar);
 +      else if (SYMBOLP (event->arg))
 +	return apply_modifiers (event->modifiers, event->arg);
 +      return event->arg;
 +
 +    case USER_SIGNAL_EVENT:
 +      /* A user signal.  */
 +      {
 +	char *name = find_user_signal_name (event->code);
 +	if (!name)
 +	  emacs_abort ();
 +	return intern (name);
 +      }
 +
 +    case SAVE_SESSION_EVENT:
 +      return Qsave_session;
 +
 +#ifdef HAVE_DBUS
 +    case DBUS_EVENT:
 +      {
 +	return Fcons (Qdbus_event, event->arg);
 +      }
 +#endif /* HAVE_DBUS */
 +
 +#if defined HAVE_GFILENOTIFY || defined HAVE_INOTIFY
 +    case FILE_NOTIFY_EVENT:
 +      {
 +        return Fcons (Qfile_notify, event->arg);
 +      }
 +#endif /* defined HAVE_GFILENOTIFY || defined HAVE_INOTIFY */
 +
 +    case CONFIG_CHANGED_EVENT:
 +	return list3 (Qconfig_changed_event,
 +		      event->arg, event->frame_or_window);
 +
 +      /* The 'kind' field of the event is something we don't recognize.  */
 +    default:
 +      emacs_abort ();
 +    }
 +}
 +
 +static Lisp_Object
 +make_lispy_movement (struct frame *frame, Lisp_Object bar_window, enum scroll_bar_part part,
 +		     Lisp_Object x, Lisp_Object y, Time t)
 +{
 +  /* Is it a scroll bar movement?  */
 +  if (frame && ! NILP (bar_window))
 +    {
 +      Lisp_Object part_sym;
 +
 +      part_sym = builtin_lisp_symbol (scroll_bar_parts[part]);
 +      return list2 (Qscroll_bar_movement,
 +		    list5 (bar_window,
 +			   Qvertical_scroll_bar,
 +			   Fcons (x, y),
 +			   make_number (t),
 +			   part_sym));
 +    }
 +  /* Or is it an ordinary mouse movement?  */
 +  else
 +    {
 +      Lisp_Object position;
 +      position = make_lispy_position (frame, x, y, t);
 +      return list2 (Qmouse_movement, position);
 +    }
 +}
 +
 +/* Construct a switch frame event.  */
 +static Lisp_Object
 +make_lispy_switch_frame (Lisp_Object frame)
 +{
 +  return list2 (Qswitch_frame, frame);
 +}
 +
 +static Lisp_Object
 +make_lispy_focus_in (Lisp_Object frame)
 +{
 +  return list2 (Qfocus_in, frame);
 +}
 +
 +#ifdef HAVE_WINDOW_SYSTEM
 +
 +static Lisp_Object
 +make_lispy_focus_out (Lisp_Object frame)
 +{
 +  return list2 (Qfocus_out, frame);
 +}
 +
 +#endif /* HAVE_WINDOW_SYSTEM */
 +
 +/* Manipulating modifiers.  */
 +
 +/* Parse the name of SYMBOL, and return the set of modifiers it contains.
 +
 +   If MODIFIER_END is non-zero, set *MODIFIER_END to the position in
 +   SYMBOL's name of the end of the modifiers; the string from this
 +   position is the unmodified symbol name.
 +
 +   This doesn't use any caches.  */
 +
 +static int
 +parse_modifiers_uncached (Lisp_Object symbol, ptrdiff_t *modifier_end)
 +{
 +  Lisp_Object name;
 +  ptrdiff_t i;
 +  int modifiers;
 +
 +  CHECK_SYMBOL (symbol);
 +
 +  modifiers = 0;
 +  name = SYMBOL_NAME (symbol);
 +
 +  for (i = 0; i < SBYTES (name) - 1; )
 +    {
 +      ptrdiff_t this_mod_end = 0;
 +      int this_mod = 0;
 +
 +      /* See if the name continues with a modifier word.
 +	 Check that the word appears, but don't check what follows it.
 +	 Set this_mod and this_mod_end to record what we find.  */
 +
 +      switch (SREF (name, i))
 +	{
 +#define SINGLE_LETTER_MOD(BIT)				\
 +	  (this_mod_end = i + 1, this_mod = BIT)
 +
 +	case 'A':
 +	  SINGLE_LETTER_MOD (alt_modifier);
 +	  break;
 +
 +	case 'C':
 +	  SINGLE_LETTER_MOD (ctrl_modifier);
 +	  break;
 +
 +	case 'H':
 +	  SINGLE_LETTER_MOD (hyper_modifier);
 +	  break;
 +
 +	case 'M':
 +	  SINGLE_LETTER_MOD (meta_modifier);
 +	  break;
 +
 +	case 'S':
 +	  SINGLE_LETTER_MOD (shift_modifier);
 +	  break;
 +
 +	case 's':
 +	  SINGLE_LETTER_MOD (super_modifier);
 +	  break;
 +
 +#undef SINGLE_LETTER_MOD
 +
 +#define MULTI_LETTER_MOD(BIT, NAME, LEN)			\
 +	  if (i + LEN + 1 <= SBYTES (name)			\
 +	      && ! memcmp (SDATA (name) + i, NAME, LEN))	\
 +	    {							\
 +	      this_mod_end = i + LEN;				\
 +	      this_mod = BIT;					\
 +	    }
 +
 +	case 'd':
 +	  MULTI_LETTER_MOD (drag_modifier, "drag", 4);
 +	  MULTI_LETTER_MOD (down_modifier, "down", 4);
 +	  MULTI_LETTER_MOD (double_modifier, "double", 6);
 +	  break;
 +
 +	case 't':
 +	  MULTI_LETTER_MOD (triple_modifier, "triple", 6);
 +	  break;
 +#undef MULTI_LETTER_MOD
 +
 +	}
 +
 +      /* If we found no modifier, stop looking for them.  */
 +      if (this_mod_end == 0)
 +	break;
 +
 +      /* Check there is a dash after the modifier, so that it
 +	 really is a modifier.  */
 +      if (this_mod_end >= SBYTES (name)
 +	  || SREF (name, this_mod_end) != '-')
 +	break;
 +
 +      /* This modifier is real; look for another.  */
 +      modifiers |= this_mod;
 +      i = this_mod_end + 1;
 +    }
 +
 +  /* Should we include the `click' modifier?  */
 +  if (! (modifiers & (down_modifier | drag_modifier
 +		      | double_modifier | triple_modifier))
 +      && i + 7 == SBYTES (name)
 +      && memcmp (SDATA (name) + i, "mouse-", 6) == 0
 +      && ('0' <= SREF (name, i + 6) && SREF (name, i + 6) <= '9'))
 +    modifiers |= click_modifier;
 +
 +  if (! (modifiers & (double_modifier | triple_modifier))
 +      && i + 6 < SBYTES (name)
 +      && memcmp (SDATA (name) + i, "wheel-", 6) == 0)
 +    modifiers |= click_modifier;
 +
 +  if (modifier_end)
 +    *modifier_end = i;
 +
 +  return modifiers;
 +}
 +
 +/* Return a symbol whose name is the modifier prefixes for MODIFIERS
 +   prepended to the string BASE[0..BASE_LEN-1].
 +   This doesn't use any caches.  */
 +static Lisp_Object
 +apply_modifiers_uncached (int modifiers, char *base, int base_len, int base_len_byte)
 +{
 +  /* Since BASE could contain nulls, we can't use intern here; we have
 +     to use Fintern, which expects a genuine Lisp_String, and keeps a
 +     reference to it.  */
 +  char new_mods[sizeof "A-C-H-M-S-s-down-drag-double-triple-"];
 +  int mod_len;
 +
 +  {
 +    char *p = new_mods;
 +
 +    /* Only the event queue may use the `up' modifier; it should always
 +       be turned into a click or drag event before presented to lisp code.  */
 +    if (modifiers & up_modifier)
 +      emacs_abort ();
 +
 +    if (modifiers & alt_modifier)   { *p++ = 'A'; *p++ = '-'; }
 +    if (modifiers & ctrl_modifier)  { *p++ = 'C'; *p++ = '-'; }
 +    if (modifiers & hyper_modifier) { *p++ = 'H'; *p++ = '-'; }
 +    if (modifiers & meta_modifier)  { *p++ = 'M'; *p++ = '-'; }
 +    if (modifiers & shift_modifier) { *p++ = 'S'; *p++ = '-'; }
 +    if (modifiers & super_modifier) { *p++ = 's'; *p++ = '-'; }
 +    if (modifiers & double_modifier) p = stpcpy (p, "double-");
 +    if (modifiers & triple_modifier) p = stpcpy (p, "triple-");
 +    if (modifiers & down_modifier) p = stpcpy (p, "down-");
 +    if (modifiers & drag_modifier) p = stpcpy (p, "drag-");
 +    /* The click modifier is denoted by the absence of other modifiers.  */
 +
 +    *p = '\0';
 +
 +    mod_len = p - new_mods;
 +  }
 +
 +  {
 +    Lisp_Object new_name;
 +
 +    new_name = make_uninit_multibyte_string (mod_len + base_len,
 +					     mod_len + base_len_byte);
 +    memcpy (SDATA (new_name), new_mods, mod_len);
 +    memcpy (SDATA (new_name) + mod_len, base, base_len_byte);
 +
 +    return Fintern (new_name, Qnil);
 +  }
 +}
 +
 +
 +static const char *const modifier_names[] =
 +{
 +  "up", "down", "drag", "click", "double", "triple", 0, 0,
 +  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
 +  0, 0, "alt", "super", "hyper", "shift", "control", "meta"
 +};
 +#define NUM_MOD_NAMES ARRAYELTS (modifier_names)
 +
 +static Lisp_Object modifier_symbols;
 +
 +/* Return the list of modifier symbols corresponding to the mask MODIFIERS.  */
 +static Lisp_Object
 +lispy_modifier_list (int modifiers)
 +{
 +  Lisp_Object modifier_list;
 +  int i;
 +
 +  modifier_list = Qnil;
 +  for (i = 0; (1<= table_size)
 +    return Qnil;
 +
 +  if (CONSP (*symbol_table))
 +    value = Fcdr (assq_no_quit (symbol_int, *symbol_table));
 +
 +  /* If *symbol_table doesn't seem to be initialized properly, fix that.
 +     *symbol_table should be a lisp vector TABLE_SIZE elements long,
 +     where the Nth element is the symbol for NAME_TABLE[N], or nil if
 +     we've never used that symbol before.  */
 +  else
 +    {
 +      if (! VECTORP (*symbol_table)
 +	  || ASIZE (*symbol_table) != table_size)
 +	{
 +	  Lisp_Object size;
 +
 +	  XSETFASTINT (size, table_size);
 +	  *symbol_table = Fmake_vector (size, Qnil);
 +	}
 +
 +      value = AREF (*symbol_table, symbol_num);
 +    }
 +
 +  /* Have we already used this symbol before?  */
 +  if (NILP (value))
 +    {
 +      /* No; let's create it.  */
 +      if (CONSP (name_alist_or_stem))
 +	value = Fcdr_safe (Fassq (symbol_int, name_alist_or_stem));
 +      else if (STRINGP (name_alist_or_stem))
 +	{
 +	  char *buf;
 +	  ptrdiff_t len = (SBYTES (name_alist_or_stem)
 +			   + sizeof "-" + INT_STRLEN_BOUND (EMACS_INT));
 +	  USE_SAFE_ALLOCA;
 +	  buf = SAFE_ALLOCA (len);
 +	  esprintf (buf, "%s-%"pI"d", SDATA (name_alist_or_stem),
 +		    XINT (symbol_int) + 1);
 +	  value = intern (buf);
 +	  SAFE_FREE ();
 +	}
 +      else if (name_table != 0 && name_table[symbol_num])
 +	value = intern (name_table[symbol_num]);
 +
 +#ifdef HAVE_WINDOW_SYSTEM
 +      if (NILP (value))
 +	{
 +	  char *name = x_get_keysym_name (symbol_num);
 +	  if (name)
 +	    value = intern (name);
 +	}
 +#endif
 +
 +      if (NILP (value))
 +	{
 +	  char buf[sizeof "key-" + INT_STRLEN_BOUND (EMACS_INT)];
 +	  sprintf (buf, "key-%"pD"d", symbol_num);
 +	  value = intern (buf);
 +	}
 +
 +      if (CONSP (*symbol_table))
 +        *symbol_table = Fcons (Fcons (symbol_int, value), *symbol_table);
 +      else
 +	ASET (*symbol_table, symbol_num, value);
 +
 +      /* Fill in the cache entries for this symbol; this also
 +	 builds the Qevent_symbol_elements property, which the user
 +	 cares about.  */
 +      apply_modifiers (modifiers & click_modifier, value);
 +      Fput (value, Qevent_kind, symbol_kind);
 +    }
 +
 +  /* Apply modifiers to that symbol.  */
 +  return apply_modifiers (modifiers, value);
 +}
 +
 +/* Convert a list that represents an event type,
 +   such as (ctrl meta backspace), into the usual representation of that
 +   event type as a number or a symbol.  */
 +
 +DEFUN ("event-convert-list", Fevent_convert_list, Sevent_convert_list, 1, 1, 0,
 +       doc: /* Convert the event description list EVENT-DESC to an event type.
 +EVENT-DESC should contain one base event type (a character or symbol)
 +and zero or more modifier names (control, meta, hyper, super, shift, alt,
 +drag, down, double or triple).  The base must be last.
 +The return value is an event type (a character or symbol) which
 +has the same base event type and all the specified modifiers.  */)
 +  (Lisp_Object event_desc)
 +{
 +  Lisp_Object base;
 +  int modifiers = 0;
 +  Lisp_Object rest;
 +
 +  base = Qnil;
 +  rest = event_desc;
 +  while (CONSP (rest))
 +    {
 +      Lisp_Object elt;
 +      int this = 0;
 +
 +      elt = XCAR (rest);
 +      rest = XCDR (rest);
 +
 +      /* Given a symbol, see if it is a modifier name.  */
 +      if (SYMBOLP (elt) && CONSP (rest))
 +	this = parse_solitary_modifier (elt);
 +
 +      if (this != 0)
 +	modifiers |= this;
 +      else if (!NILP (base))
 +	error ("Two bases given in one event");
 +      else
 +	base = elt;
 +
 +    }
 +
 +  /* Let the symbol A refer to the character A.  */
 +  if (SYMBOLP (base) && SCHARS (SYMBOL_NAME (base)) == 1)
 +    XSETINT (base, SREF (SYMBOL_NAME (base), 0));
 +
 +  if (INTEGERP (base))
 +    {
 +      /* Turn (shift a) into A.  */
 +      if ((modifiers & shift_modifier) != 0
 +	  && (XINT (base) >= 'a' && XINT (base) <= 'z'))
 +	{
 +	  XSETINT (base, XINT (base) - ('a' - 'A'));
 +	  modifiers &= ~shift_modifier;
 +	}
 +
 +      /* Turn (control a) into C-a.  */
 +      if (modifiers & ctrl_modifier)
 +	return make_number ((modifiers & ~ctrl_modifier)
 +			    | make_ctrl_char (XINT (base)));
 +      else
 +	return make_number (modifiers | XINT (base));
 +    }
 +  else if (SYMBOLP (base))
 +    return apply_modifiers (modifiers, base);
 +  else
 +    error ("Invalid base event");
 +}
 +
 +/* Try to recognize SYMBOL as a modifier name.
 +   Return the modifier flag bit, or 0 if not recognized.  */
 +
 +int
 +parse_solitary_modifier (Lisp_Object symbol)
 +{
 +  Lisp_Object name = SYMBOL_NAME (symbol);
 +
 +  switch (SREF (name, 0))
 +    {
 +#define SINGLE_LETTER_MOD(BIT)				\
 +      if (SBYTES (name) == 1)				\
 +	return BIT;
 +
 +#define MULTI_LETTER_MOD(BIT, NAME, LEN)		\
 +      if (LEN == SBYTES (name)				\
 +	  && ! memcmp (SDATA (name), NAME, LEN))	\
 +	return BIT;
 +
 +    case 'A':
 +      SINGLE_LETTER_MOD (alt_modifier);
 +      break;
 +
 +    case 'a':
 +      MULTI_LETTER_MOD (alt_modifier, "alt", 3);
 +      break;
 +
 +    case 'C':
 +      SINGLE_LETTER_MOD (ctrl_modifier);
 +      break;
 +
 +    case 'c':
 +      MULTI_LETTER_MOD (ctrl_modifier, "ctrl", 4);
 +      MULTI_LETTER_MOD (ctrl_modifier, "control", 7);
 +      break;
 +
 +    case 'H':
 +      SINGLE_LETTER_MOD (hyper_modifier);
 +      break;
 +
 +    case 'h':
 +      MULTI_LETTER_MOD (hyper_modifier, "hyper", 5);
 +      break;
 +
 +    case 'M':
 +      SINGLE_LETTER_MOD (meta_modifier);
 +      break;
 +
 +    case 'm':
 +      MULTI_LETTER_MOD (meta_modifier, "meta", 4);
 +      break;
 +
 +    case 'S':
 +      SINGLE_LETTER_MOD (shift_modifier);
 +      break;
 +
 +    case 's':
 +      MULTI_LETTER_MOD (shift_modifier, "shift", 5);
 +      MULTI_LETTER_MOD (super_modifier, "super", 5);
 +      SINGLE_LETTER_MOD (super_modifier);
 +      break;
 +
 +    case 'd':
 +      MULTI_LETTER_MOD (drag_modifier, "drag", 4);
 +      MULTI_LETTER_MOD (down_modifier, "down", 4);
 +      MULTI_LETTER_MOD (double_modifier, "double", 6);
 +      break;
 +
 +    case 't':
 +      MULTI_LETTER_MOD (triple_modifier, "triple", 6);
 +      break;
 +
 +#undef SINGLE_LETTER_MOD
 +#undef MULTI_LETTER_MOD
 +    }
 +
 +  return 0;
 +}
 +
 +/* Return true if EVENT is a list whose elements are all integers or symbols.
 +   Such a list is not valid as an event,
 +   but it can be a Lucid-style event type list.  */
 +
 +bool
 +lucid_event_type_list_p (Lisp_Object object)
 +{
 +  Lisp_Object tail;
 +
 +  if (! CONSP (object))
 +    return 0;
 +
 +  if (EQ (XCAR (object), Qhelp_echo)
 +      || EQ (XCAR (object), Qvertical_line)
 +      || EQ (XCAR (object), Qmode_line)
 +      || EQ (XCAR (object), Qheader_line))
 +    return 0;
 +
 +  for (tail = object; CONSP (tail); tail = XCDR (tail))
 +    {
 +      Lisp_Object elt;
 +      elt = XCAR (tail);
 +      if (! (INTEGERP (elt) || SYMBOLP (elt)))
 +	return 0;
 +    }
 +
 +  return NILP (tail);
 +}
 +
 +/* Return true if terminal input chars are available.
 +   Also, store the return value into INPUT_PENDING.
 +
 +   Serves the purpose of ioctl (0, FIONREAD, ...)
 +   but works even if FIONREAD does not exist.
 +   (In fact, this may actually read some input.)
 +
 +   If READABLE_EVENTS_DO_TIMERS_NOW is set in FLAGS, actually run
 +   timer events that are ripe.
 +   If READABLE_EVENTS_FILTER_EVENTS is set in FLAGS, ignore internal
 +   events (FOCUS_IN_EVENT).
 +   If READABLE_EVENTS_IGNORE_SQUEEZABLES is set in FLAGS, ignore mouse
 +   movements and toolkit scroll bar thumb drags.  */
 +
 +static bool
 +get_input_pending (int flags)
 +{
 +  /* First of all, have we already counted some input?  */
 +  input_pending = (!NILP (Vquit_flag) || readable_events (flags));
 +
 +  /* If input is being read as it arrives, and we have none, there is none.  */
 +  if (!input_pending && (!interrupt_input || interrupts_deferred))
 +    {
 +      /* Try to read some input and see how much we get.  */
 +      gobble_input ();
 +      input_pending = (!NILP (Vquit_flag) || readable_events (flags));
 +    }
 +
 +  return input_pending;
 +}
 +
 +/* Put a BUFFER_SWITCH_EVENT in the buffer
 +   so that read_key_sequence will notice the new current buffer.  */
 +
 +void
 +record_asynch_buffer_change (void)
 +{
 +  /* We don't need a buffer-switch event unless Emacs is waiting for input.
 +     The purpose of the event is to make read_key_sequence look up the
 +     keymaps again.  If we aren't in read_key_sequence, we don't need one,
 +     and the event could cause trouble by messing up (input-pending-p).
 +     Note: Fwaiting_for_user_input_p always returns nil when async
 +     subprocesses aren't supported.  */
 +  if (!NILP (Fwaiting_for_user_input_p ()))
 +    {
 +      struct input_event event;
 +
 +      EVENT_INIT (event);
 +      event.kind = BUFFER_SWITCH_EVENT;
 +      event.frame_or_window = Qnil;
 +      event.arg = Qnil;
 +
 +      /* Make sure no interrupt happens while storing the event.  */
 +#ifdef USABLE_SIGIO
 +      if (interrupt_input)
 +	kbd_buffer_store_event (&event);
 +      else
 +#endif
 +	{
 +	  stop_polling ();
 +	  kbd_buffer_store_event (&event);
 +	  start_polling ();
 +	}
 +    }
 +}
 +
 +/* Read any terminal input already buffered up by the system
 +   into the kbd_buffer, but do not wait.
 +
 +   Return the number of keyboard chars read, or -1 meaning
 +   this is a bad time to try to read input.  */
 +
 +int
 +gobble_input (void)
 +{
 +  int nread = 0;
 +  bool err = 0;
 +  struct terminal *t;
 +
 +  /* Store pending user signal events, if any.  */
 +  store_user_signal_events ();
 +
 +  /* Loop through the available terminals, and call their input hooks.  */
 +  t = terminal_list;
 +  while (t)
 +    {
 +      struct terminal *next = t->next_terminal;
 +
 +      if (t->read_socket_hook)
 +        {
 +          int nr;
 +          struct input_event hold_quit;
 +
 +	  if (input_blocked_p ())
 +	    {
 +	      pending_signals = 1;
 +	      break;
 +	    }
 +
 +          EVENT_INIT (hold_quit);
 +          hold_quit.kind = NO_EVENT;
 +
 +          /* No need for FIONREAD or fcntl; just say don't wait.  */
 +	  while ((nr = (*t->read_socket_hook) (t, &hold_quit)) > 0)
 +	    nread += nr;
 +
 +          if (nr == -1)          /* Not OK to read input now.  */
 +            {
 +              err = 1;
 +            }
 +          else if (nr == -2)          /* Non-transient error.  */
 +            {
 +              /* The terminal device terminated; it should be closed.  */
 +
 +              /* Kill Emacs if this was our last terminal.  */
 +              if (!terminal_list->next_terminal)
 +                /* Formerly simply reported no input, but that
 +                   sometimes led to a failure of Emacs to terminate.
 +                   SIGHUP seems appropriate if we can't reach the
 +                   terminal.  */
 +                /* ??? Is it really right to send the signal just to
 +                   this process rather than to the whole process
 +                   group?  Perhaps on systems with FIONREAD Emacs is
 +                   alone in its group.  */
 +		terminate_due_to_signal (SIGHUP, 10);
 +
 +              /* XXX Is calling delete_terminal safe here?  It calls delete_frame.  */
 +	      {
 +		Lisp_Object tmp;
 +		XSETTERMINAL (tmp, t);
 +		Fdelete_terminal (tmp, Qnoelisp);
 +	      }
 +            }
 +
 +	  /* If there was no error, make sure the pointer
 +	     is visible for all frames on this terminal.  */
 +	  if (nr >= 0)
 +	    {
 +	      Lisp_Object tail, frame;
 +
 +	      FOR_EACH_FRAME (tail, frame)
 +		{
 +		  struct frame *f = XFRAME (frame);
 +		  if (FRAME_TERMINAL (f) == t)
 +		    frame_make_pointer_visible (f);
 +		}
 +	    }
 +
 +          if (hold_quit.kind != NO_EVENT)
 +            kbd_buffer_store_event (&hold_quit);
 +        }
 +
 +      t = next;
 +    }
 +
 +  if (err && !nread)
 +    nread = -1;
 +
 +  return nread;
 +}
 +
 +/* This is the tty way of reading available input.
 +
 +   Note that each terminal device has its own `struct terminal' object,
 +   and so this function is called once for each individual termcap
 +   terminal.  The first parameter indicates which terminal to read from.  */
 +
 +int
 +tty_read_avail_input (struct terminal *terminal,
 +                      struct input_event *hold_quit)
 +{
 +  /* Using KBD_BUFFER_SIZE - 1 here avoids reading more than
 +     the kbd_buffer can really hold.  That may prevent loss
 +     of characters on some systems when input is stuffed at us.  */
 +  unsigned char cbuf[KBD_BUFFER_SIZE - 1];
 +  int n_to_read, i;
 +  struct tty_display_info *tty = terminal->display_info.tty;
 +  int nread = 0;
 +#ifdef subprocesses
 +  int buffer_free = KBD_BUFFER_SIZE - kbd_buffer_nr_stored () - 1;
 +
 +  if (kbd_on_hold_p () || buffer_free <= 0)
 +    return 0;
 +#endif	/* subprocesses */
 +
 +  if (!terminal->name)		/* Don't read from a dead terminal.  */
 +    return 0;
 +
 +  if (terminal->type != output_termcap
 +      && terminal->type != output_msdos_raw)
 +    emacs_abort ();
 +
 +  /* XXX I think the following code should be moved to separate hook
 +     functions in system-dependent files.  */
 +#ifdef WINDOWSNT
 +  /* FIXME: AFAIK, tty_read_avail_input is not used under w32 since the non-GUI
 +     code sets read_socket_hook to w32_console_read_socket instead!  */
 +  return 0;
 +#else /* not WINDOWSNT */
 +  if (! tty->term_initted)      /* In case we get called during bootstrap.  */
 +    return 0;
 +
 +  if (! tty->input)
 +    return 0;                   /* The terminal is suspended.  */
 +
 +#ifdef MSDOS
 +  n_to_read = dos_keysns ();
 +  if (n_to_read == 0)
 +    return 0;
 +
 +  cbuf[0] = dos_keyread ();
 +  nread = 1;
 +
 +#else /* not MSDOS */
 +#ifdef HAVE_GPM
 +  if (gpm_tty == tty)
 +  {
 +      Gpm_Event event;
 +      struct input_event gpm_hold_quit;
 +      int gpm, fd = gpm_fd;
 +
 +      EVENT_INIT (gpm_hold_quit);
 +      gpm_hold_quit.kind = NO_EVENT;
 +
 +      /* gpm==1 if event received.
 +         gpm==0 if the GPM daemon has closed the connection, in which case
 +                Gpm_GetEvent closes gpm_fd and clears it to -1, which is why
 +		we save it in `fd' so close_gpm can remove it from the
 +		select masks.
 +         gpm==-1 if a protocol error or EWOULDBLOCK; the latter is normal.  */
 +      while (gpm = Gpm_GetEvent (&event), gpm == 1) {
 +	  nread += handle_one_term_event (tty, &event, &gpm_hold_quit);
 +      }
 +      if (gpm == 0)
 +	/* Presumably the GPM daemon has closed the connection.  */
 +	close_gpm (fd);
 +      if (gpm_hold_quit.kind != NO_EVENT)
 +	  kbd_buffer_store_event (&gpm_hold_quit);
 +      if (nread)
 +	  return nread;
 +  }
 +#endif /* HAVE_GPM */
 +
 +/* Determine how many characters we should *try* to read.  */
 +#ifdef USABLE_FIONREAD
 +  /* Find out how much input is available.  */
 +  if (ioctl (fileno (tty->input), FIONREAD, &n_to_read) < 0)
 +    {
 +      if (! noninteractive)
 +        return -2;          /* Close this terminal.  */
 +      else
 +        n_to_read = 0;
 +    }
 +  if (n_to_read == 0)
 +    return 0;
 +  if (n_to_read > sizeof cbuf)
 +    n_to_read = sizeof cbuf;
 +#elif defined USG || defined CYGWIN
 +  /* Read some input if available, but don't wait.  */
 +  n_to_read = sizeof cbuf;
 +  fcntl (fileno (tty->input), F_SETFL, O_NONBLOCK);
 +#else
 +# error "Cannot read without possibly delaying"
 +#endif
 +
 +#ifdef subprocesses
 +  /* Don't read more than we can store.  */
 +  if (n_to_read > buffer_free)
 +    n_to_read = buffer_free;
 +#endif	/* subprocesses */
 +
 +  /* Now read; for one reason or another, this will not block.
 +     NREAD is set to the number of chars read.  */
 +  do
 +    {
 +      nread = emacs_read (fileno (tty->input), (char *) cbuf, n_to_read);
 +      /* POSIX infers that processes which are not in the session leader's
 +         process group won't get SIGHUPs at logout time.  BSDI adheres to
 +         this part standard and returns -1 from read (0) with errno==EIO
 +         when the control tty is taken away.
 +         Jeffrey Honig  says this is generally safe.  */
 +      if (nread == -1 && errno == EIO)
 +        return -2;          /* Close this terminal.  */
 +#if defined (AIX) && defined (_BSD)
 +      /* The kernel sometimes fails to deliver SIGHUP for ptys.
 +         This looks incorrect, but it isn't, because _BSD causes
 +         O_NDELAY to be defined in fcntl.h as O_NONBLOCK,
 +         and that causes a value other than 0 when there is no input.  */
 +      if (nread == 0)
 +        return -2;          /* Close this terminal.  */
 +#endif
 +    }
 +  while (
 +         /* We used to retry the read if it was interrupted.
 +            But this does the wrong thing when O_NONBLOCK causes
 +            an EAGAIN error.  Does anybody know of a situation
 +            where a retry is actually needed?  */
 +#if 0
 +         nread < 0 && (errno == EAGAIN || errno == EFAULT
 +#ifdef EBADSLT
 +                       || errno == EBADSLT
 +#endif
 +                       )
 +#else
 +         0
 +#endif
 +         );
 +
 +#ifndef USABLE_FIONREAD
 +#if defined (USG) || defined (CYGWIN)
 +  fcntl (fileno (tty->input), F_SETFL, 0);
 +#endif /* USG or CYGWIN */
 +#endif /* no FIONREAD */
 +
 +  if (nread <= 0)
 +    return nread;
 +
 +#endif /* not MSDOS */
 +#endif /* not WINDOWSNT */
 +
 +  for (i = 0; i < nread; i++)
 +    {
 +      struct input_event buf;
 +      EVENT_INIT (buf);
 +      buf.kind = ASCII_KEYSTROKE_EVENT;
 +      buf.modifiers = 0;
 +      if (tty->meta_key == 1 && (cbuf[i] & 0x80))
 +        buf.modifiers = meta_modifier;
 +      if (tty->meta_key != 2)
 +        cbuf[i] &= ~0x80;
 +
 +      buf.code = cbuf[i];
 +      /* Set the frame corresponding to the active tty.  Note that the
 +         value of selected_frame is not reliable here, redisplay tends
 +         to temporarily change it.  */
 +      buf.frame_or_window = tty->top_frame;
 +      buf.arg = Qnil;
 +
 +      kbd_buffer_store_event (&buf);
 +      /* Don't look at input that follows a C-g too closely.
 +         This reduces lossage due to autorepeat on C-g.  */
 +      if (buf.kind == ASCII_KEYSTROKE_EVENT
 +          && buf.code == quit_char)
 +        break;
 +    }
 +
 +  return nread;
 +}
 +
 +static void
 +handle_async_input (void)
 +{
 +#ifdef USABLE_SIGIO
 +  while (1)
 +    {
 +      int nread = gobble_input ();
 +      /* -1 means it's not ok to read the input now.
 +	 UNBLOCK_INPUT will read it later; now, avoid infinite loop.
 +	 0 means there was no keyboard input available.  */
 +      if (nread <= 0)
 +	break;
 +    }
 +#endif
 +}
 +
 +void
 +process_pending_signals (void)
 +{
 +  pending_signals = 0;
 +  handle_async_input ();
 +  do_pending_atimers ();
 +}
 +
 +/* Undo any number of BLOCK_INPUT calls down to level LEVEL,
 +   and reinvoke any pending signal if the level is now 0 and
 +   a fatal error is not already in progress.  */
 +
 +void
 +unblock_input_to (int level)
 +{
 +  interrupt_input_blocked = level;
 +  if (level == 0)
 +    {
 +      if (pending_signals && !fatal_error_in_progress)
 +	process_pending_signals ();
 +    }
 +  else if (level < 0)
 +    emacs_abort ();
 +}
 +
 +/* End critical section.
 +
 +   If doing signal-driven input, and a signal came in when input was
 +   blocked, reinvoke the signal handler now to deal with it.
 +
 +   It will also process queued input, if it was not read before.
 +   When a longer code sequence does not use block/unblock input
 +   at all, the whole input gathered up to the next call to
 +   unblock_input will be processed inside that call. */
 +
 +void
 +unblock_input (void)
 +{
 +  unblock_input_to (interrupt_input_blocked - 1);
 +}
 +
 +/* Undo any number of BLOCK_INPUT calls,
 +   and also reinvoke any pending signal.  */
 +
 +void
 +totally_unblock_input (void)
 +{
 +  unblock_input_to (0);
 +}
 +
 +#ifdef USABLE_SIGIO
 +
 +void
 +handle_input_available_signal (int sig)
 +{
 +  pending_signals = 1;
 +
 +  if (input_available_clear_time)
 +    *input_available_clear_time = make_timespec (0, 0);
 +}
 +
 +static void
 +deliver_input_available_signal (int sig)
 +{
 +  deliver_process_signal (sig, handle_input_available_signal);
 +}
 +#endif /* USABLE_SIGIO */
 +
 +
 +/* User signal events.  */
 +
 +struct user_signal_info
 +{
 +  /* Signal number.  */
 +  int sig;
 +
 +  /* Name of the signal.  */
 +  char *name;
 +
 +  /* Number of pending signals.  */
 +  int npending;
 +
 +  struct user_signal_info *next;
 +};
 +
 +/* List of user signals.  */
 +static struct user_signal_info *user_signals = NULL;
 +
 +void
 +add_user_signal (int sig, const char *name)
 +{
 +  struct sigaction action;
 +  struct user_signal_info *p;
 +
 +  for (p = user_signals; p; p = p->next)
 +    if (p->sig == sig)
 +      /* Already added.  */
 +      return;
 +
 +  p = xmalloc (sizeof *p);
 +  p->sig = sig;
 +  p->name = xstrdup (name);
 +  p->npending = 0;
 +  p->next = user_signals;
 +  user_signals = p;
 +
 +  emacs_sigaction_init (&action, deliver_user_signal);
 +  sigaction (sig, &action, 0);
 +}
 +
 +static void
 +handle_user_signal (int sig)
 +{
 +  struct user_signal_info *p;
 +  const char *special_event_name = NULL;
 +
 +  if (SYMBOLP (Vdebug_on_event))
 +    special_event_name = SSDATA (SYMBOL_NAME (Vdebug_on_event));
 +
 +  for (p = user_signals; p; p = p->next)
 +    if (p->sig == sig)
 +      {
 +        if (special_event_name
 +	    && strcmp (special_event_name, p->name) == 0)
 +          {
 +            /* Enter the debugger in many ways.  */
 +            debug_on_next_call = 1;
 +            debug_on_quit = 1;
 +            Vquit_flag = Qt;
 +            Vinhibit_quit = Qnil;
 +
 +            /* Eat the event.  */
 +            break;
 +          }
 +
 +	p->npending++;
 +#ifdef USABLE_SIGIO
 +	if (interrupt_input)
 +	  handle_input_available_signal (sig);
 +	else
 +#endif
 +	  {
 +	    /* Tell wait_reading_process_output that it needs to wake
 +	       up and look around.  */
 +	    if (input_available_clear_time)
 +	      *input_available_clear_time = make_timespec (0, 0);
 +	  }
 +	break;
 +      }
 +}
 +
 +static void
 +deliver_user_signal (int sig)
 +{
 +  deliver_process_signal (sig, handle_user_signal);
 +}
 +
 +static char *
 +find_user_signal_name (int sig)
 +{
 +  struct user_signal_info *p;
 +
 +  for (p = user_signals; p; p = p->next)
 +    if (p->sig == sig)
 +      return p->name;
 +
 +  return NULL;
 +}
 +
 +static void
 +store_user_signal_events (void)
 +{
 +  struct user_signal_info *p;
 +  struct input_event buf;
 +  bool buf_initialized = 0;
 +
 +  for (p = user_signals; p; p = p->next)
 +    if (p->npending > 0)
 +      {
 +	if (! buf_initialized)
 +	  {
 +	    memset (&buf, 0, sizeof buf);
 +	    buf.kind = USER_SIGNAL_EVENT;
 +	    buf.frame_or_window = selected_frame;
 +	    buf_initialized = 1;
 +	  }
 +
 +	do
 +	  {
 +	    buf.code = p->sig;
 +	    kbd_buffer_store_event (&buf);
 +	    p->npending--;
 +	  }
 +	while (p->npending > 0);
 +      }
 +}
 +
 +
 +static void menu_bar_item (Lisp_Object, Lisp_Object, Lisp_Object, void *);
 +static Lisp_Object menu_bar_one_keymap_changed_items;
 +
 +/* These variables hold the vector under construction within
 +   menu_bar_items and its subroutines, and the current index
 +   for storing into that vector.  */
 +static Lisp_Object menu_bar_items_vector;
 +static int menu_bar_items_index;
 +
 +
 +static const char *separator_names[] = {
 +  "space",
 +  "no-line",
 +  "single-line",
 +  "double-line",
 +  "single-dashed-line",
 +  "double-dashed-line",
 +  "shadow-etched-in",
 +  "shadow-etched-out",
 +  "shadow-etched-in-dash",
 +  "shadow-etched-out-dash",
 +  "shadow-double-etched-in",
 +  "shadow-double-etched-out",
 +  "shadow-double-etched-in-dash",
 +  "shadow-double-etched-out-dash",
 +  0,
 +};
 +
 +/* Return true if LABEL specifies a separator.  */
 +
 +bool
 +menu_separator_name_p (const char *label)
 +{
 +  if (!label)
 +    return 0;
 +  else if (strlen (label) > 3
 +	   && memcmp (label, "--", 2) == 0
 +	   && label[2] != '-')
 +    {
 +      int i;
 +      label += 2;
 +      for (i = 0; separator_names[i]; ++i)
 +	if (strcmp (label, separator_names[i]) == 0)
 +          return 1;
 +    }
 +  else
 +    {
 +      /* It's a separator if it contains only dashes.  */
 +      while (*label == '-')
 +	++label;
 +      return (*label == 0);
 +    }
 +
 +  return 0;
 +}
 +
 +
 +/* Return a vector of menu items for a menu bar, appropriate
 +   to the current buffer.  Each item has three elements in the vector:
 +   KEY STRING MAPLIST.
 +
 +   OLD is an old vector we can optionally reuse, or nil.  */
 +
 +Lisp_Object
 +menu_bar_items (Lisp_Object old)
 +{
 +  /* The number of keymaps we're scanning right now, and the number of
 +     keymaps we have allocated space for.  */
 +  ptrdiff_t nmaps;
 +
 +  /* maps[0..nmaps-1] are the prefix definitions of KEYBUF[0..t-1]
 +     in the current keymaps, or nil where it is not a prefix.  */
 +  Lisp_Object *maps;
 +
 +  Lisp_Object mapsbuf[3];
 +  Lisp_Object def, tail;
 +
 +  ptrdiff_t mapno;
 +  Lisp_Object oquit;
 +
 +  USE_SAFE_ALLOCA;
 +
 +  /* In order to build the menus, we need to call the keymap
 +     accessors.  They all call QUIT.  But this function is called
 +     during redisplay, during which a quit is fatal.  So inhibit
 +     quitting while building the menus.
 +     We do this instead of specbind because (1) errors will clear it anyway
 +     and (2) this avoids risk of specpdl overflow.  */
 +  oquit = Vinhibit_quit;
 +  Vinhibit_quit = Qt;
 +
 +  if (!NILP (old))
 +    menu_bar_items_vector = old;
 +  else
 +    menu_bar_items_vector = Fmake_vector (make_number (24), Qnil);
 +  menu_bar_items_index = 0;
 +
 +  /* Build our list of keymaps.
 +     If we recognize a function key and replace its escape sequence in
 +     keybuf with its symbol, or if the sequence starts with a mouse
 +     click and we need to switch buffers, we jump back here to rebuild
 +     the initial keymaps from the current buffer.  */
 +  {
 +    Lisp_Object *tmaps;
 +
 +    /* Should overriding-terminal-local-map and overriding-local-map apply?  */
 +    if (!NILP (Voverriding_local_map_menu_flag)
 +	&& !NILP (Voverriding_local_map))
 +      {
 +	/* Yes, use them (if non-nil) as well as the global map.  */
 +	maps = mapsbuf;
 +	nmaps = 0;
 +	if (!NILP (KVAR (current_kboard, Voverriding_terminal_local_map)))
 +	  maps[nmaps++] = KVAR (current_kboard, Voverriding_terminal_local_map);
 +	if (!NILP (Voverriding_local_map))
 +	  maps[nmaps++] = Voverriding_local_map;
 +      }
 +    else
 +      {
 +	/* No, so use major and minor mode keymaps and keymap property.
 +	   Note that menu-bar bindings in the local-map and keymap
 +	   properties may not work reliable, as they are only
 +	   recognized when the menu-bar (or mode-line) is updated,
 +	   which does not normally happen after every command.  */
 +	Lisp_Object tem;
 +	ptrdiff_t nminor;
 +	nminor = current_minor_maps (NULL, &tmaps);
 +	SAFE_NALLOCA (maps, 1, nminor + 4);
 +	nmaps = 0;
 +	tem = KVAR (current_kboard, Voverriding_terminal_local_map);
 +	if (!NILP (tem) && !NILP (Voverriding_local_map_menu_flag))
 +	  maps[nmaps++] = tem;
 +	if (tem = get_local_map (PT, current_buffer, Qkeymap), !NILP (tem))
 +	  maps[nmaps++] = tem;
 +	memcpy (maps + nmaps, tmaps, nminor * sizeof (maps[0]));
 +	nmaps += nminor;
 +	maps[nmaps++] = get_local_map (PT, current_buffer, Qlocal_map);
 +      }
 +    maps[nmaps++] = current_global_map;
 +  }
 +
 +  /* Look up in each map the dummy prefix key `menu-bar'.  */
 +
 +  for (mapno = nmaps - 1; mapno >= 0; mapno--)
 +    if (!NILP (maps[mapno]))
 +      {
 +	def = get_keymap (access_keymap (maps[mapno], Qmenu_bar, 1, 0, 1),
 +			  0, 1);
 +	if (CONSP (def))
 +	  {
 +	    menu_bar_one_keymap_changed_items = Qnil;
 +	    map_keymap_canonical (def, menu_bar_item, Qnil, NULL);
 +	  }
 +      }
 +
 +  /* Move to the end those items that should be at the end.  */
 +
 +  for (tail = Vmenu_bar_final_items; CONSP (tail); tail = XCDR (tail))
 +    {
 +      int i;
 +      int end = menu_bar_items_index;
 +
 +      for (i = 0; i < end; i += 4)
 +	if (EQ (XCAR (tail), AREF (menu_bar_items_vector, i)))
 +	  {
 +	    Lisp_Object tem0, tem1, tem2, tem3;
 +	    /* Move the item at index I to the end,
 +	       shifting all the others forward.  */
 +	    tem0 = AREF (menu_bar_items_vector, i + 0);
 +	    tem1 = AREF (menu_bar_items_vector, i + 1);
 +	    tem2 = AREF (menu_bar_items_vector, i + 2);
 +	    tem3 = AREF (menu_bar_items_vector, i + 3);
 +	    if (end > i + 4)
 +	      memmove (aref_addr (menu_bar_items_vector, i),
 +		       aref_addr (menu_bar_items_vector, i + 4),
 +		       (end - i - 4) * word_size);
 +	    ASET (menu_bar_items_vector, end - 4, tem0);
 +	    ASET (menu_bar_items_vector, end - 3, tem1);
 +	    ASET (menu_bar_items_vector, end - 2, tem2);
 +	    ASET (menu_bar_items_vector, end - 1, tem3);
 +	    break;
 +	  }
 +    }
 +
 +  /* Add nil, nil, nil, nil at the end.  */
 +  {
 +    int i = menu_bar_items_index;
 +    if (i + 4 > ASIZE (menu_bar_items_vector))
 +      menu_bar_items_vector
 +	= larger_vector (menu_bar_items_vector, 4, -1);
 +    /* Add this item.  */
 +    ASET (menu_bar_items_vector, i, Qnil); i++;
 +    ASET (menu_bar_items_vector, i, Qnil); i++;
 +    ASET (menu_bar_items_vector, i, Qnil); i++;
 +    ASET (menu_bar_items_vector, i, Qnil); i++;
 +    menu_bar_items_index = i;
 +  }
 +
 +  Vinhibit_quit = oquit;
 +  SAFE_FREE ();
 +  return menu_bar_items_vector;
 +}
 +
 +/* Add one item to menu_bar_items_vector, for KEY, ITEM_STRING and DEF.
 +   If there's already an item for KEY, add this DEF to it.  */
 +
 +Lisp_Object item_properties;
 +
 +static void
 +menu_bar_item (Lisp_Object key, Lisp_Object item, Lisp_Object dummy1, void *dummy2)
 +{
 +  struct gcpro gcpro1;
 +  int i;
 +  bool parsed;
 +  Lisp_Object tem;
 +
 +  if (EQ (item, Qundefined))
 +    {
 +      /* If a map has an explicit `undefined' as definition,
 +	 discard any previously made menu bar item.  */
 +
 +      for (i = 0; i < menu_bar_items_index; i += 4)
 +	if (EQ (key, AREF (menu_bar_items_vector, i)))
 +	  {
 +	    if (menu_bar_items_index > i + 4)
 +	      memmove (aref_addr (menu_bar_items_vector, i),
 +		       aref_addr (menu_bar_items_vector, i + 4),
 +		       (menu_bar_items_index - i - 4) * word_size);
 +	    menu_bar_items_index -= 4;
 +	  }
 +    }
 +
 +  /* If this keymap has already contributed to this KEY,
 +     don't contribute to it a second time.  */
 +  tem = Fmemq (key, menu_bar_one_keymap_changed_items);
 +  if (!NILP (tem) || NILP (item))
 +    return;
 +
 +  menu_bar_one_keymap_changed_items
 +    = Fcons (key, menu_bar_one_keymap_changed_items);
 +
 +  /* We add to menu_bar_one_keymap_changed_items before doing the
 +     parse_menu_item, so that if it turns out it wasn't a menu item,
 +     it still correctly hides any further menu item.  */
 +  GCPRO1 (key);
 +  parsed = parse_menu_item (item, 1);
 +  UNGCPRO;
 +  if (!parsed)
 +    return;
 +
 +  item = AREF (item_properties, ITEM_PROPERTY_DEF);
 +
 +  /* Find any existing item for this KEY.  */
 +  for (i = 0; i < menu_bar_items_index; i += 4)
 +    if (EQ (key, AREF (menu_bar_items_vector, i)))
 +      break;
 +
 +  /* If we did not find this KEY, add it at the end.  */
 +  if (i == menu_bar_items_index)
 +    {
 +      /* If vector is too small, get a bigger one.  */
 +      if (i + 4 > ASIZE (menu_bar_items_vector))
 +	menu_bar_items_vector = larger_vector (menu_bar_items_vector, 4, -1);
 +      /* Add this item.  */
 +      ASET (menu_bar_items_vector, i, key); i++;
 +      ASET (menu_bar_items_vector, i,
 +	    AREF (item_properties, ITEM_PROPERTY_NAME)); i++;
 +      ASET (menu_bar_items_vector, i, list1 (item)); i++;
 +      ASET (menu_bar_items_vector, i, make_number (0)); i++;
 +      menu_bar_items_index = i;
 +    }
 +  /* We did find an item for this KEY.  Add ITEM to its list of maps.  */
 +  else
 +    {
 +      Lisp_Object old;
 +      old = AREF (menu_bar_items_vector, i + 2);
 +      /* If the new and the old items are not both keymaps,
 +	 the lookup will only find `item'.  */
 +      item = Fcons (item, KEYMAPP (item) && KEYMAPP (XCAR (old)) ? old : Qnil);
 +      ASET (menu_bar_items_vector, i + 2, item);
 +    }
 +}
 +
 + /* This is used as the handler when calling menu_item_eval_property.  */
 +static Lisp_Object
 +menu_item_eval_property_1 (Lisp_Object arg)
 +{
 +  /* If we got a quit from within the menu computation,
 +     quit all the way out of it.  This takes care of C-] in the debugger.  */
 +  if (CONSP (arg) && EQ (XCAR (arg), Qquit))
 +    Fsignal (Qquit, Qnil);
 +
 +  return Qnil;
 +}
 +
 +static Lisp_Object
 +eval_dyn (Lisp_Object form)
 +{
 +  return Feval (form, Qnil);
 +}
 +
 +/* Evaluate an expression and return the result (or nil if something
 +   went wrong).  Used to evaluate dynamic parts of menu items.  */
 +Lisp_Object
 +menu_item_eval_property (Lisp_Object sexpr)
 +{
 +  ptrdiff_t count = SPECPDL_INDEX ();
 +  Lisp_Object val;
 +  specbind (Qinhibit_redisplay, Qt);
 +  val = internal_condition_case_1 (eval_dyn, sexpr, Qerror,
 +				   menu_item_eval_property_1);
 +  return unbind_to (count, val);
 +}
 +
 +/* This function parses a menu item and leaves the result in the
 +   vector item_properties.
 +   ITEM is a key binding, a possible menu item.
 +   INMENUBAR is > 0 when this is considered for an entry in a menu bar
 +   top level.
 +   INMENUBAR is < 0 when this is considered for an entry in a keyboard menu.
 +   parse_menu_item returns true if the item is a menu item and false
 +   otherwise.  */
 +
 +bool
 +parse_menu_item (Lisp_Object item, int inmenubar)
 +{
 +  Lisp_Object def, tem, item_string, start;
 +  Lisp_Object filter;
 +  Lisp_Object keyhint;
 +  int i;
 +
 +  filter = Qnil;
 +  keyhint = Qnil;
 +
 +  if (!CONSP (item))
 +    return 0;
 +
 +  /* Create item_properties vector if necessary.  */
 +  if (NILP (item_properties))
 +    item_properties
 +      = Fmake_vector (make_number (ITEM_PROPERTY_ENABLE + 1), Qnil);
 +
 +  /* Initialize optional entries.  */
 +  for (i = ITEM_PROPERTY_DEF; i < ITEM_PROPERTY_ENABLE; i++)
 +    ASET (item_properties, i, Qnil);
 +  ASET (item_properties, ITEM_PROPERTY_ENABLE, Qt);
 +
 +  /* Save the item here to protect it from GC.  */
 +  ASET (item_properties, ITEM_PROPERTY_ITEM, item);
 +
 +  item_string = XCAR (item);
 +
 +  start = item;
 +  item = XCDR (item);
 +  if (STRINGP (item_string))
 +    {
 +      /* Old format menu item.  */
 +      ASET (item_properties, ITEM_PROPERTY_NAME, item_string);
 +
 +      /* Maybe help string.  */
 +      if (CONSP (item) && STRINGP (XCAR (item)))
 +	{
 +	  ASET (item_properties, ITEM_PROPERTY_HELP, XCAR (item));
 +	  start = item;
 +	  item = XCDR (item);
 +	}
 +
 +      /* Maybe an obsolete key binding cache.  */
 +      if (CONSP (item) && CONSP (XCAR (item))
 +	  && (NILP (XCAR (XCAR (item)))
 +	      || VECTORP (XCAR (XCAR (item)))))
 +	item = XCDR (item);
 +
 +      /* This is the real definition--the function to run.  */
 +      ASET (item_properties, ITEM_PROPERTY_DEF, item);
 +
 +      /* Get enable property, if any.  */
 +      if (SYMBOLP (item))
 +	{
 +	  tem = Fget (item, Qmenu_enable);
 +	  if (!NILP (Venable_disabled_menus_and_buttons))
 +	    ASET (item_properties, ITEM_PROPERTY_ENABLE, Qt);
 +	  else if (!NILP (tem))
 +	    ASET (item_properties, ITEM_PROPERTY_ENABLE, tem);
 +	}
 +    }
 +  else if (EQ (item_string, Qmenu_item) && CONSP (item))
 +    {
 +      /* New format menu item.  */
 +      ASET (item_properties, ITEM_PROPERTY_NAME, XCAR (item));
 +      start = XCDR (item);
 +      if (CONSP (start))
 +	{
 +	  /* We have a real binding.  */
 +	  ASET (item_properties, ITEM_PROPERTY_DEF, XCAR (start));
 +
 +	  item = XCDR (start);
 +	  /* Is there an obsolete cache list with key equivalences.  */
 +	  if (CONSP (item) && CONSP (XCAR (item)))
 +	    item = XCDR (item);
 +
 +	  /* Parse properties.  */
 +	  while (CONSP (item) && CONSP (XCDR (item)))
 +	    {
 +	      tem = XCAR (item);
 +	      item = XCDR (item);
 +
 +	      if (EQ (tem, QCenable))
 +		{
 +		  if (!NILP (Venable_disabled_menus_and_buttons))
 +		    ASET (item_properties, ITEM_PROPERTY_ENABLE, Qt);
 +		  else
 +		    ASET (item_properties, ITEM_PROPERTY_ENABLE, XCAR (item));
 +		}
 +	      else if (EQ (tem, QCvisible))
 +		{
 +		  /* If got a visible property and that evaluates to nil
 +		     then ignore this item.  */
 +		  tem = menu_item_eval_property (XCAR (item));
 +		  if (NILP (tem))
 +		    return 0;
 +	 	}
 +	      else if (EQ (tem, QChelp))
 +		ASET (item_properties, ITEM_PROPERTY_HELP, XCAR (item));
 +	      else if (EQ (tem, QCfilter))
 +		filter = item;
 +	      else if (EQ (tem, QCkey_sequence))
 +		{
 +		  tem = XCAR (item);
 +		  if (SYMBOLP (tem) || STRINGP (tem) || VECTORP (tem))
 +		    /* Be GC protected. Set keyhint to item instead of tem.  */
 +		    keyhint = item;
 +		}
 +	      else if (EQ (tem, QCkeys))
 +		{
 +		  tem = XCAR (item);
 +		  if (CONSP (tem) || STRINGP (tem))
 +		    ASET (item_properties, ITEM_PROPERTY_KEYEQ, tem);
 +		}
 +	      else if (EQ (tem, QCbutton) && CONSP (XCAR (item)))
 +		{
 +		  Lisp_Object type;
 +		  tem = XCAR (item);
 +		  type = XCAR (tem);
 +		  if (EQ (type, QCtoggle) || EQ (type, QCradio))
 +		    {
 +		      ASET (item_properties, ITEM_PROPERTY_SELECTED,
 +			    XCDR (tem));
 +		      ASET (item_properties, ITEM_PROPERTY_TYPE, type);
 +		    }
 +		}
 +	      item = XCDR (item);
 +	    }
 +	}
 +      else if (inmenubar || !NILP (start))
 +	return 0;
 +    }
 +  else
 +    return 0;			/* not a menu item */
 +
 +  /* If item string is not a string, evaluate it to get string.
 +     If we don't get a string, skip this item.  */
 +  item_string = AREF (item_properties, ITEM_PROPERTY_NAME);
 +  if (!(STRINGP (item_string)))
 +    {
 +      item_string = menu_item_eval_property (item_string);
 +      if (!STRINGP (item_string))
 +	return 0;
 +      ASET (item_properties, ITEM_PROPERTY_NAME, item_string);
 +    }
 +
 +  /* If got a filter apply it on definition.  */
 +  def = AREF (item_properties, ITEM_PROPERTY_DEF);
 +  if (!NILP (filter))
 +    {
 +      def = menu_item_eval_property (list2 (XCAR (filter),
 +					    list2 (Qquote, def)));
 +
 +      ASET (item_properties, ITEM_PROPERTY_DEF, def);
 +    }
 +
 +  /* Enable or disable selection of item.  */
 +  tem = AREF (item_properties, ITEM_PROPERTY_ENABLE);
 +  if (!EQ (tem, Qt))
 +    {
 +      tem = menu_item_eval_property (tem);
 +      if (inmenubar && NILP (tem))
 +	return 0;		/* Ignore disabled items in menu bar.  */
 +      ASET (item_properties, ITEM_PROPERTY_ENABLE, tem);
 +    }
 +
 +  /* If we got no definition, this item is just unselectable text which
 +     is OK in a submenu but not in the menubar.  */
 +  if (NILP (def))
 +    return (!inmenubar);
 +
 +  /* See if this is a separate pane or a submenu.  */
 +  def = AREF (item_properties, ITEM_PROPERTY_DEF);
 +  tem = get_keymap (def, 0, 1);
 +  /* For a subkeymap, just record its details and exit.  */
 +  if (CONSP (tem))
 +    {
 +      ASET (item_properties, ITEM_PROPERTY_MAP, tem);
 +      ASET (item_properties, ITEM_PROPERTY_DEF, tem);
 +      return 1;
 +    }
 +
 +  /* At the top level in the menu bar, do likewise for commands also.
 +     The menu bar does not display equivalent key bindings anyway.
 +     ITEM_PROPERTY_DEF is already set up properly.  */
 +  if (inmenubar > 0)
 +    return 1;
 +
 +  { /* This is a command.  See if there is an equivalent key binding.  */
 +    Lisp_Object keyeq = AREF (item_properties, ITEM_PROPERTY_KEYEQ);
 +    AUTO_STRING (space_space, "  ");
 +
 +    /* The previous code preferred :key-sequence to :keys, so we
 +       preserve this behavior.  */
 +    if (STRINGP (keyeq) && !CONSP (keyhint))
 +      keyeq = concat2 (space_space, Fsubstitute_command_keys (keyeq));
 +    else
 +      {
 +	Lisp_Object prefix = keyeq;
 +	Lisp_Object keys = Qnil;
 +
 +	if (CONSP (prefix))
 +	  {
 +	    def = XCAR (prefix);
 +	    prefix = XCDR (prefix);
 +	  }
 +	else
 +	  def = AREF (item_properties, ITEM_PROPERTY_DEF);
 +
 +	if (CONSP (keyhint) && !NILP (XCAR (keyhint)))
 +	  {
 +	    keys = XCAR (keyhint);
 +	    tem = Fkey_binding (keys, Qnil, Qnil, Qnil);
 +
 +	    /* We have a suggested key.  Is it bound to the command?  */
 +	    if (NILP (tem)
 +		|| (!EQ (tem, def)
 +		    /* If the command is an alias for another
 +		       (such as lmenu.el set it up), check if the
 +		       original command matches the cached command.  */
 +		    && !(SYMBOLP (def)
 +			 && EQ (tem, XSYMBOL (def)->function))))
 +	      keys = Qnil;
 +	  }
 +
 +	if (NILP (keys))
 +	  keys = Fwhere_is_internal (def, Qnil, Qt, Qnil, Qnil);
 +
 +	if (!NILP (keys))
 +	  {
 +	    tem = Fkey_description (keys, Qnil);
 +	    if (CONSP (prefix))
 +	      {
 +		if (STRINGP (XCAR (prefix)))
 +		  tem = concat2 (XCAR (prefix), tem);
 +		if (STRINGP (XCDR (prefix)))
 +		  tem = concat2 (tem, XCDR (prefix));
 +	      }
 +	    keyeq = concat2 (space_space, tem);
 +	  }
 +	else
 +	  keyeq = Qnil;
 +      }
 +
 +    /* If we have an equivalent key binding, use that.  */
 +    ASET (item_properties, ITEM_PROPERTY_KEYEQ, keyeq);
 +  }
 +
 +  /* Include this when menu help is implemented.
 +  tem = XVECTOR (item_properties)->contents[ITEM_PROPERTY_HELP];
 +  if (!(NILP (tem) || STRINGP (tem)))
 +    {
 +      tem = menu_item_eval_property (tem);
 +      if (!STRINGP (tem))
 +	tem = Qnil;
 +      XVECTOR (item_properties)->contents[ITEM_PROPERTY_HELP] = tem;
 +    }
 +  */
 +
 +  /* Handle radio buttons or toggle boxes.  */
 +  tem = AREF (item_properties, ITEM_PROPERTY_SELECTED);
 +  if (!NILP (tem))
 +    ASET (item_properties, ITEM_PROPERTY_SELECTED,
 +	  menu_item_eval_property (tem));
 +
 +  return 1;
 +}
 +
 +
 +
 +/***********************************************************************
 +			       Tool-bars
 + ***********************************************************************/
 +
 +/* A vector holding tool bar items while they are parsed in function
 +   tool_bar_items. Each item occupies TOOL_BAR_ITEM_NSCLOTS elements
 +   in the vector.  */
 +
 +static Lisp_Object tool_bar_items_vector;
 +
 +/* A vector holding the result of parse_tool_bar_item.  Layout is like
 +   the one for a single item in tool_bar_items_vector.  */
 +
 +static Lisp_Object tool_bar_item_properties;
 +
 +/* Next free index in tool_bar_items_vector.  */
 +
 +static int ntool_bar_items;
 +
 +/* Function prototypes.  */
 +
 +static void init_tool_bar_items (Lisp_Object);
 +static void process_tool_bar_item (Lisp_Object, Lisp_Object, Lisp_Object,
 +				   void *);
 +static bool parse_tool_bar_item (Lisp_Object, Lisp_Object);
 +static void append_tool_bar_item (void);
 +
 +
 +/* Return a vector of tool bar items for keymaps currently in effect.
 +   Reuse vector REUSE if non-nil.  Return in *NITEMS the number of
 +   tool bar items found.  */
 +
 +Lisp_Object
 +tool_bar_items (Lisp_Object reuse, int *nitems)
 +{
 +  Lisp_Object *maps;
 +  Lisp_Object mapsbuf[3];
 +  ptrdiff_t nmaps, i;
 +  Lisp_Object oquit;
 +  Lisp_Object *tmaps;
 +  USE_SAFE_ALLOCA;
 +
 +  *nitems = 0;
 +
 +  /* In order to build the menus, we need to call the keymap
 +     accessors.  They all call QUIT.  But this function is called
 +     during redisplay, during which a quit is fatal.  So inhibit
 +     quitting while building the menus.  We do this instead of
 +     specbind because (1) errors will clear it anyway and (2) this
 +     avoids risk of specpdl overflow.  */
 +  oquit = Vinhibit_quit;
 +  Vinhibit_quit = Qt;
 +
 +  /* Initialize tool_bar_items_vector and protect it from GC.  */
 +  init_tool_bar_items (reuse);
 +
 +  /* Build list of keymaps in maps.  Set nmaps to the number of maps
 +     to process.  */
 +
 +  /* Should overriding-terminal-local-map and overriding-local-map apply?  */
 +  if (!NILP (Voverriding_local_map_menu_flag)
 +      && !NILP (Voverriding_local_map))
 +    {
 +      /* Yes, use them (if non-nil) as well as the global map.  */
 +      maps = mapsbuf;
 +      nmaps = 0;
 +      if (!NILP (KVAR (current_kboard, Voverriding_terminal_local_map)))
 +	maps[nmaps++] = KVAR (current_kboard, Voverriding_terminal_local_map);
 +      if (!NILP (Voverriding_local_map))
 +	maps[nmaps++] = Voverriding_local_map;
 +    }
 +  else
 +    {
 +      /* No, so use major and minor mode keymaps and keymap property.
 +	 Note that tool-bar bindings in the local-map and keymap
 +	 properties may not work reliable, as they are only
 +	 recognized when the tool-bar (or mode-line) is updated,
 +	 which does not normally happen after every command.  */
 +      Lisp_Object tem;
 +      ptrdiff_t nminor;
 +      nminor = current_minor_maps (NULL, &tmaps);
 +      SAFE_NALLOCA (maps, 1, nminor + 4);
 +      nmaps = 0;
 +      tem = KVAR (current_kboard, Voverriding_terminal_local_map);
 +      if (!NILP (tem) && !NILP (Voverriding_local_map_menu_flag))
 +	maps[nmaps++] = tem;
 +      if (tem = get_local_map (PT, current_buffer, Qkeymap), !NILP (tem))
 +	maps[nmaps++] = tem;
 +      memcpy (maps + nmaps, tmaps, nminor * sizeof (maps[0]));
 +      nmaps += nminor;
 +      maps[nmaps++] = get_local_map (PT, current_buffer, Qlocal_map);
 +    }
 +
 +  /* Add global keymap at the end.  */
 +  maps[nmaps++] = current_global_map;
 +
 +  /* Process maps in reverse order and look up in each map the prefix
 +     key `tool-bar'.  */
 +  for (i = nmaps - 1; i >= 0; --i)
 +    if (!NILP (maps[i]))
 +      {
 +	Lisp_Object keymap;
 +
 +	keymap = get_keymap (access_keymap (maps[i], Qtool_bar, 1, 0, 1), 0, 1);
 +	if (CONSP (keymap))
 +	  map_keymap (keymap, process_tool_bar_item, Qnil, NULL, 1);
 +      }
 +
 +  Vinhibit_quit = oquit;
 +  *nitems = ntool_bar_items / TOOL_BAR_ITEM_NSLOTS;
 +  SAFE_FREE ();
 +  return tool_bar_items_vector;
 +}
 +
 +
 +/* Process the definition of KEY which is DEF.  */
 +
 +static void
 +process_tool_bar_item (Lisp_Object key, Lisp_Object def, Lisp_Object data, void *args)
 +{
 +  int i;
 +  struct gcpro gcpro1, gcpro2;
 +
 +  /* Protect KEY and DEF from GC because parse_tool_bar_item may call
 +     eval.  */
 +  GCPRO2 (key, def);
 +
 +  if (EQ (def, Qundefined))
 +    {
 +      /* If a map has an explicit `undefined' as definition,
 +	 discard any previously made item.  */
 +      for (i = 0; i < ntool_bar_items; i += TOOL_BAR_ITEM_NSLOTS)
 +	{
 +	  Lisp_Object *v = XVECTOR (tool_bar_items_vector)->contents + i;
 +
 +	  if (EQ (key, v[TOOL_BAR_ITEM_KEY]))
 +	    {
 +	      if (ntool_bar_items > i + TOOL_BAR_ITEM_NSLOTS)
 +		memmove (v, v + TOOL_BAR_ITEM_NSLOTS,
 +			 ((ntool_bar_items - i - TOOL_BAR_ITEM_NSLOTS)
 +			  * word_size));
 +	      ntool_bar_items -= TOOL_BAR_ITEM_NSLOTS;
 +	      break;
 +	    }
 +	}
 +    }
 +  else if (parse_tool_bar_item (key, def))
 +    /* Append a new tool bar item to tool_bar_items_vector.  Accept
 +       more than one definition for the same key.  */
 +    append_tool_bar_item ();
 +
 +  UNGCPRO;
 +}
 +
 +/* Access slot with index IDX of vector tool_bar_item_properties.  */
 +#define PROP(IDX) AREF (tool_bar_item_properties, (IDX))
 +static void
 +set_prop (ptrdiff_t idx, Lisp_Object val)
 +{
 +  ASET (tool_bar_item_properties, idx, val);
 +}
 +
 +
 +/* Parse a tool bar item specification ITEM for key KEY and return the
 +   result in tool_bar_item_properties.  Value is false if ITEM is
 +   invalid.
 +
 +   ITEM is a list `(menu-item CAPTION BINDING PROPS...)'.
 +
 +   CAPTION is the caption of the item,  If it's not a string, it is
 +   evaluated to get a string.
 +
 +   BINDING is the tool bar item's binding.  Tool-bar items with keymaps
 +   as binding are currently ignored.
 +
 +   The following properties are recognized:
 +
 +   - `:enable FORM'.
 +
 +   FORM is evaluated and specifies whether the tool bar item is
 +   enabled or disabled.
 +
 +   - `:visible FORM'
 +
 +   FORM is evaluated and specifies whether the tool bar item is visible.
 +
 +   - `:filter FUNCTION'
 +
 +   FUNCTION is invoked with one parameter `(quote BINDING)'.  Its
 +   result is stored as the new binding.
 +
 +   - `:button (TYPE SELECTED)'
 +
 +   TYPE must be one of `:radio' or `:toggle'.  SELECTED is evaluated
 +   and specifies whether the button is selected (pressed) or not.
 +
 +   - `:image IMAGES'
 +
 +   IMAGES is either a single image specification or a vector of four
 +   image specifications.  See enum tool_bar_item_images.
 +
 +   - `:help HELP-STRING'.
 +
 +   Gives a help string to display for the tool bar item.
 +
 +   - `:label LABEL-STRING'.
 +
 +   A text label to show with the tool bar button if labels are enabled.  */
 +
 +static bool
 +parse_tool_bar_item (Lisp_Object key, Lisp_Object item)
 +{
 +  Lisp_Object filter = Qnil;
 +  Lisp_Object caption;
 +  int i;
 +  bool have_label = 0;
 +
 +  /* Definition looks like `(menu-item CAPTION BINDING PROPS...)'.
 +     Rule out items that aren't lists, don't start with
 +     `menu-item' or whose rest following `tool-bar-item' is not a
 +     list.  */
 +  if (!CONSP (item))
 +    return 0;
 +
 +  /* As an exception, allow old-style menu separators.  */
 +  if (STRINGP (XCAR (item)))
 +    item = list1 (XCAR (item));
 +  else if (!EQ (XCAR (item), Qmenu_item)
 +	   || (item = XCDR (item), !CONSP (item)))
 +    return 0;
 +
 +  /* Create tool_bar_item_properties vector if necessary.  Reset it to
 +     defaults.  */
 +  if (VECTORP (tool_bar_item_properties))
 +    {
 +      for (i = 0; i < TOOL_BAR_ITEM_NSLOTS; ++i)
 +	set_prop (i, Qnil);
 +    }
 +  else
 +    tool_bar_item_properties
 +      = Fmake_vector (make_number (TOOL_BAR_ITEM_NSLOTS), Qnil);
 +
 +  /* Set defaults.  */
 +  set_prop (TOOL_BAR_ITEM_KEY, key);
 +  set_prop (TOOL_BAR_ITEM_ENABLED_P, Qt);
 +
 +  /* Get the caption of the item.  If the caption is not a string,
 +     evaluate it to get a string.  If we don't get a string, skip this
 +     item.  */
 +  caption = XCAR (item);
 +  if (!STRINGP (caption))
 +    {
 +      caption = menu_item_eval_property (caption);
 +      if (!STRINGP (caption))
 +	return 0;
 +    }
 +  set_prop (TOOL_BAR_ITEM_CAPTION, caption);
 +
 +  /* If the rest following the caption is not a list, the menu item is
 +     either a separator, or invalid.  */
 +  item = XCDR (item);
 +  if (!CONSP (item))
 +    {
 +      if (menu_separator_name_p (SSDATA (caption)))
 +	{
 +	  set_prop (TOOL_BAR_ITEM_TYPE, Qt);
 +#if !defined (USE_GTK) && !defined (HAVE_NS)
 +	  /* If we use build_desired_tool_bar_string to render the
 +	     tool bar, the separator is rendered as an image.  */
 +	  set_prop (TOOL_BAR_ITEM_IMAGES,
 +		    (menu_item_eval_property
 +		     (Vtool_bar_separator_image_expression)));
 +	  set_prop (TOOL_BAR_ITEM_ENABLED_P, Qnil);
 +	  set_prop (TOOL_BAR_ITEM_SELECTED_P, Qnil);
 +	  set_prop (TOOL_BAR_ITEM_CAPTION, Qnil);
 +#endif
 +	  return 1;
 +	}
 +      return 0;
 +    }
 +
 +  /* Store the binding.  */
 +  set_prop (TOOL_BAR_ITEM_BINDING, XCAR (item));
 +  item = XCDR (item);
 +
 +  /* Ignore cached key binding, if any.  */
 +  if (CONSP (item) && CONSP (XCAR (item)))
 +    item = XCDR (item);
 +
 +  /* Process the rest of the properties.  */
 +  for (; CONSP (item) && CONSP (XCDR (item)); item = XCDR (XCDR (item)))
 +    {
 +      Lisp_Object ikey, value;
 +
 +      ikey = XCAR (item);
 +      value = XCAR (XCDR (item));
 +
 +      if (EQ (ikey, QCenable))
 +	{
 +	  /* `:enable FORM'.  */
 +	  if (!NILP (Venable_disabled_menus_and_buttons))
 +	    set_prop (TOOL_BAR_ITEM_ENABLED_P, Qt);
 +	  else
 +	    set_prop (TOOL_BAR_ITEM_ENABLED_P, value);
 +	}
 +      else if (EQ (ikey, QCvisible))
 +	{
 +	  /* `:visible FORM'.  If got a visible property and that
 +	     evaluates to nil then ignore this item.  */
 +	  if (NILP (menu_item_eval_property (value)))
 +	    return 0;
 +	}
 +      else if (EQ (ikey, QChelp))
 +        /* `:help HELP-STRING'.  */
 +        set_prop (TOOL_BAR_ITEM_HELP, value);
 +      else if (EQ (ikey, QCvert_only))
 +        /* `:vert-only t/nil'.  */
 +        set_prop (TOOL_BAR_ITEM_VERT_ONLY, value);
 +      else if (EQ (ikey, QClabel))
 +        {
 +          const char *bad_label = "!!?GARBLED ITEM?!!";
 +          /* `:label LABEL-STRING'.  */
 +          set_prop (TOOL_BAR_ITEM_LABEL,
 +		    STRINGP (value) ? value : build_string (bad_label));
 +          have_label = 1;
 +        }
 +      else if (EQ (ikey, QCfilter))
 +	/* ':filter FORM'.  */
 +	filter = value;
 +      else if (EQ (ikey, QCbutton) && CONSP (value))
 +	{
 +	  /* `:button (TYPE . SELECTED)'.  */
 +	  Lisp_Object type, selected;
 +
 +	  type = XCAR (value);
 +	  selected = XCDR (value);
 +	  if (EQ (type, QCtoggle) || EQ (type, QCradio))
 +	    {
 +	      set_prop (TOOL_BAR_ITEM_SELECTED_P, selected);
 +	      set_prop (TOOL_BAR_ITEM_TYPE, type);
 +	    }
 +	}
 +      else if (EQ (ikey, QCimage)
 +	       && (CONSP (value)
 +		   || (VECTORP (value) && ASIZE (value) == 4)))
 +	/* Value is either a single image specification or a vector
 +	   of 4 such specifications for the different button states.  */
 +	set_prop (TOOL_BAR_ITEM_IMAGES, value);
 +      else if (EQ (ikey, QCrtl))
 +        /* ':rtl STRING' */
 +	set_prop (TOOL_BAR_ITEM_RTL_IMAGE, value);
 +    }
 +
 +
 +  if (!have_label)
 +    {
 +      /* Try to make one from caption and key.  */
 +      Lisp_Object tkey = PROP (TOOL_BAR_ITEM_KEY);
 +      Lisp_Object tcapt = PROP (TOOL_BAR_ITEM_CAPTION);
 +      const char *label = SYMBOLP (tkey) ? SSDATA (SYMBOL_NAME (tkey)) : "";
 +      const char *capt = STRINGP (tcapt) ? SSDATA (tcapt) : "";
 +      ptrdiff_t max_lbl =
 +	2 * max (0, min (tool_bar_max_label_size, STRING_BYTES_BOUND / 2));
 +      char *buf = xmalloc (max_lbl + 1);
 +      Lisp_Object new_lbl;
 +      ptrdiff_t caption_len = strlen (capt);
 +
 +      if (caption_len <= max_lbl && capt[0] != '\0')
 +        {
 +          strcpy (buf, capt);
 +          while (caption_len > 0 && buf[caption_len - 1] == '.')
 +            caption_len--;
 +	  buf[caption_len] = '\0';
 +	  label = capt = buf;
 +        }
 +
 +      if (strlen (label) <= max_lbl && label[0] != '\0')
 +        {
 +          ptrdiff_t j;
 +          if (label != buf)
 +	    strcpy (buf, label);
 +
 +          for (j = 0; buf[j] != '\0'; ++j)
 +	    if (buf[j] == '-')
 +	      buf[j] = ' ';
 +          label = buf;
 +        }
 +      else
 +	label = "";
 +
 +      new_lbl = Fupcase_initials (build_string (label));
 +      if (SCHARS (new_lbl) <= tool_bar_max_label_size)
 +        set_prop (TOOL_BAR_ITEM_LABEL, new_lbl);
 +      else
 +        set_prop (TOOL_BAR_ITEM_LABEL, empty_unibyte_string);
 +      xfree (buf);
 +    }
 +
 +  /* If got a filter apply it on binding.  */
 +  if (!NILP (filter))
 +    set_prop (TOOL_BAR_ITEM_BINDING,
 +	      (menu_item_eval_property
 +	       (list2 (filter,
 +		       list2 (Qquote,
 +			      PROP (TOOL_BAR_ITEM_BINDING))))));
 +
 +  /* See if the binding is a keymap.  Give up if it is.  */
 +  if (CONSP (get_keymap (PROP (TOOL_BAR_ITEM_BINDING), 0, 1)))
 +    return 0;
 +
 +  /* Enable or disable selection of item.  */
 +  if (!EQ (PROP (TOOL_BAR_ITEM_ENABLED_P), Qt))
 +    set_prop (TOOL_BAR_ITEM_ENABLED_P,
 +	      menu_item_eval_property (PROP (TOOL_BAR_ITEM_ENABLED_P)));
 +
 +  /* Handle radio buttons or toggle boxes.  */
 +  if (!NILP (PROP (TOOL_BAR_ITEM_SELECTED_P)))
 +    set_prop (TOOL_BAR_ITEM_SELECTED_P,
 +	      menu_item_eval_property (PROP (TOOL_BAR_ITEM_SELECTED_P)));
 +
 +  return 1;
 +
 +#undef PROP
 +}
 +
 +
 +/* Initialize tool_bar_items_vector.  REUSE, if non-nil, is a vector
 +   that can be reused.  */
 +
 +static void
 +init_tool_bar_items (Lisp_Object reuse)
 +{
 +  if (VECTORP (reuse))
 +    tool_bar_items_vector = reuse;
 +  else
 +    tool_bar_items_vector = Fmake_vector (make_number (64), Qnil);
 +  ntool_bar_items = 0;
 +}
 +
 +
 +/* Append parsed tool bar item properties from
 +   tool_bar_item_properties */
 +
 +static void
 +append_tool_bar_item (void)
 +{
 +  ptrdiff_t incr
 +    = (ntool_bar_items
 +       - (ASIZE (tool_bar_items_vector) - TOOL_BAR_ITEM_NSLOTS));
 +
 +  /* Enlarge tool_bar_items_vector if necessary.  */
 +  if (incr > 0)
 +    tool_bar_items_vector = larger_vector (tool_bar_items_vector, incr, -1);
 +
 +  /* Append entries from tool_bar_item_properties to the end of
 +     tool_bar_items_vector.  */
 +  vcopy (tool_bar_items_vector, ntool_bar_items,
 +	 XVECTOR (tool_bar_item_properties)->contents, TOOL_BAR_ITEM_NSLOTS);
 +  ntool_bar_items += TOOL_BAR_ITEM_NSLOTS;
 +}
 +
 +
 +
 +
 +
 +/* Read a character using menus based on the keymap MAP.
 +   Return nil if there are no menus in the maps.
 +   Return t if we displayed a menu but the user rejected it.
 +
 +   PREV_EVENT is the previous input event, or nil if we are reading
 +   the first event of a key sequence.
 +
 +   If USED_MOUSE_MENU is non-null, set *USED_MOUSE_MENU to true
 +   if we used a mouse menu to read the input, or false otherwise.  If
 +   USED_MOUSE_MENU is null, don't dereference it.
 +
 +   The prompting is done based on the prompt-string of the map
 +   and the strings associated with various map elements.
 +
 +   This can be done with X menus or with menus put in the minibuf.
 +   These are done in different ways, depending on how the input will be read.
 +   Menus using X are done after auto-saving in read-char, getting the input
 +   event from Fx_popup_menu; menus using the minibuf use read_char recursively
 +   and do auto-saving in the inner call of read_char.  */
 +
 +static Lisp_Object
 +read_char_x_menu_prompt (Lisp_Object map,
 +			 Lisp_Object prev_event, bool *used_mouse_menu)
 +{
 +  if (used_mouse_menu)
 +    *used_mouse_menu = 0;
 +
 +  /* Use local over global Menu maps.  */
 +
 +  if (! menu_prompting)
 +    return Qnil;
 +
 +  /* If we got to this point via a mouse click,
 +     use a real menu for mouse selection.  */
 +  if (EVENT_HAS_PARAMETERS (prev_event)
 +      && !EQ (XCAR (prev_event), Qmenu_bar)
 +      && !EQ (XCAR (prev_event), Qtool_bar))
 +    {
 +      /* Display the menu and get the selection.  */
 +      Lisp_Object value;
 +
 +      value = Fx_popup_menu (prev_event, get_keymap (map, 0, 1));
 +      if (CONSP (value))
 +	{
 +	  Lisp_Object tem;
 +
 +	  record_menu_key (XCAR (value));
 +
 +	  /* If we got multiple events, unread all but
 +	     the first.
 +	     There is no way to prevent those unread events
 +	     from showing up later in last_nonmenu_event.
 +	     So turn symbol and integer events into lists,
 +	     to indicate that they came from a mouse menu,
 +	     so that when present in last_nonmenu_event
 +	     they won't confuse things.  */
 +	  for (tem = XCDR (value); CONSP (tem); tem = XCDR (tem))
 +	    {
 +	      record_menu_key (XCAR (tem));
 +	      if (SYMBOLP (XCAR (tem))
 +		  || INTEGERP (XCAR (tem)))
 +		XSETCAR (tem, Fcons (XCAR (tem), Qdisabled));
 +	    }
 +
 +	  /* If we got more than one event, put all but the first
 +	     onto this list to be read later.
 +	     Return just the first event now.  */
 +	  Vunread_command_events
 +	    = nconc2 (XCDR (value), Vunread_command_events);
 +	  value = XCAR (value);
 +	}
 +      else if (NILP (value))
 +	value = Qt;
 +      if (used_mouse_menu)
 +	*used_mouse_menu = 1;
 +      return value;
 +    }
 +  return Qnil ;
 +}
 +
 +static Lisp_Object
 +read_char_minibuf_menu_prompt (int commandflag,
 +			       Lisp_Object map)
 +{
 +  Lisp_Object name;
 +  ptrdiff_t nlength;
 +  /* FIXME: Use the minibuffer's frame width.  */
 +  ptrdiff_t width = FRAME_COLS (SELECTED_FRAME ()) - 4;
 +  ptrdiff_t idx = -1;
 +  bool nobindings = 1;
 +  Lisp_Object rest, vector;
 +  Lisp_Object prompt_strings = Qnil;
 +
 +  vector = Qnil;
 +
 +  if (! menu_prompting)
 +    return Qnil;
 +
 +  map = get_keymap (map, 0, 1);
 +  name = Fkeymap_prompt (map);
 +
 +  /* If we don't have any menus, just read a character normally.  */
 +  if (!STRINGP (name))
 +    return Qnil;
 +
 +#define PUSH_C_STR(str, listvar) \
 +  listvar = Fcons (build_unibyte_string (str), listvar)
 +
 +  /* Prompt string always starts with map's prompt, and a space.  */
 +  prompt_strings = Fcons (name, prompt_strings);
 +  PUSH_C_STR (": ", prompt_strings);
 +  nlength = SCHARS (name) + 2;
 +
 +  rest = map;
 +
 +  /* Present the documented bindings, a line at a time.  */
 +  while (1)
 +    {
 +      bool notfirst = 0;
 +      Lisp_Object menu_strings = prompt_strings;
 +      ptrdiff_t i = nlength;
 +      Lisp_Object obj;
 +      Lisp_Object orig_defn_macro;
 +
 +      /* Loop over elements of map.  */
 +      while (i < width)
 +	{
 +	  Lisp_Object elt;
 +
 +	  /* FIXME: Use map_keymap to handle new keymap formats.  */
 +
 +	  /* At end of map, wrap around if just starting,
 +	     or end this line if already have something on it.  */
 +	  if (NILP (rest))
 +	    {
 +	      if (notfirst || nobindings)
 +		break;
 +	      else
 +		rest = map;
 +	    }
 +
 +	  /* Look at the next element of the map.  */
 +	  if (idx >= 0)
 +	    elt = AREF (vector, idx);
 +	  else
 +	    elt = Fcar_safe (rest);
 +
 +	  if (idx < 0 && VECTORP (elt))
 +	    {
 +	      /* If we found a dense table in the keymap,
 +		 advanced past it, but start scanning its contents.  */
 +	      rest = Fcdr_safe (rest);
 +	      vector = elt;
 +	      idx = 0;
 +	    }
 +	  else
 +	    {
 +	      /* An ordinary element.  */
 +	      Lisp_Object event, tem;
 +
 +	      if (idx < 0)
 +		{
 +		  event = Fcar_safe (elt); /* alist */
 +		  elt = Fcdr_safe (elt);
 +		}
 +	      else
 +		{
 +		  XSETINT (event, idx); /* vector */
 +		}
 +
 +	      /* Ignore the element if it has no prompt string.  */
 +	      if (INTEGERP (event) && parse_menu_item (elt, -1))
 +		{
 +		  /* True if the char to type matches the string.  */
 +		  bool char_matches;
 +		  Lisp_Object upcased_event, downcased_event;
 +		  Lisp_Object desc = Qnil;
 +		  Lisp_Object s
 +		    = AREF (item_properties, ITEM_PROPERTY_NAME);
 +
 +		  upcased_event = Fupcase (event);
 +		  downcased_event = Fdowncase (event);
 +		  char_matches = (XINT (upcased_event) == SREF (s, 0)
 +				  || XINT (downcased_event) == SREF (s, 0));
 +		  if (! char_matches)
 +		    desc = Fsingle_key_description (event, Qnil);
 +
 +#if 0  /* It is redundant to list the equivalent key bindings because
 +	  the prefix is what the user has already typed.  */
 +		  tem
 +		    = XVECTOR (item_properties)->contents[ITEM_PROPERTY_KEYEQ];
 +		  if (!NILP (tem))
 +		    /* Insert equivalent keybinding.  */
 +		    s = concat2 (s, tem);
 +#endif
 +		  tem
 +		    = AREF (item_properties, ITEM_PROPERTY_TYPE);
 +		  if (EQ (tem, QCradio) || EQ (tem, QCtoggle))
 +		    {
 +		      /* Insert button prefix.  */
 +		      Lisp_Object selected
 +			= AREF (item_properties, ITEM_PROPERTY_SELECTED);
 +		      AUTO_STRING (radio_yes, "(*) ");
 +		      AUTO_STRING (radio_no , "( ) ");
 +		      AUTO_STRING (check_yes, "[X] ");
 +		      AUTO_STRING (check_no , "[ ] ");
 +		      if (EQ (tem, QCradio))
 +			tem = NILP (selected) ? radio_yes : radio_no;
 +		      else
 +			tem = NILP (selected) ? check_yes : check_no;
 +		      s = concat2 (tem, s);
 +		    }
 +
 +
 +		  /* If we have room for the prompt string, add it to this line.
 +		     If this is the first on the line, always add it.  */
 +		  if ((SCHARS (s) + i + 2
 +		       + (char_matches ? 0 : SCHARS (desc) + 3))
 +		      < width
 +		      || !notfirst)
 +		    {
 +		      ptrdiff_t thiswidth;
 +
 +		      /* Punctuate between strings.  */
 +		      if (notfirst)
 +			{
 +			  PUSH_C_STR (", ", menu_strings);
 +			  i += 2;
 +			}
 +		      notfirst = 1;
 +		      nobindings = 0;
 +
 +		      /* If the char to type doesn't match the string's
 +			 first char, explicitly show what char to type.  */
 +		      if (! char_matches)
 +			{
 +			  /* Add as much of string as fits.  */
 +			  thiswidth = min (SCHARS (desc), width - i);
 +			  menu_strings
 +			    = Fcons (Fsubstring (desc, make_number (0),
 +						 make_number (thiswidth)),
 +				     menu_strings);
 +			  i += thiswidth;
 +			  PUSH_C_STR (" = ", menu_strings);
 +			  i += 3;
 +			}
 +
 +		      /* Add as much of string as fits.  */
 +		      thiswidth = min (SCHARS (s), width - i);
 +		      menu_strings
 +			= Fcons (Fsubstring (s, make_number (0),
 +					     make_number (thiswidth)),
 +				 menu_strings);
 +		      i += thiswidth;
 +		    }
 +		  else
 +		    {
 +		      /* If this element does not fit, end the line now,
 +			 and save the element for the next line.  */
 +		      PUSH_C_STR ("...", menu_strings);
 +		      break;
 +		    }
 +		}
 +
 +	      /* Move past this element.  */
 +	      if (idx >= 0 && idx + 1 >= ASIZE (vector))
 +		/* Handle reaching end of dense table.  */
 +		idx = -1;
 +	      if (idx >= 0)
 +		idx++;
 +	      else
 +		rest = Fcdr_safe (rest);
 +	    }
 +	}
 +
 +      /* Prompt with that and read response.  */
 +      message3_nolog (apply1 (intern ("concat"), Fnreverse (menu_strings)));
 +
 +      /* Make believe it's not a keyboard macro in case the help char
 +	 is pressed.  Help characters are not recorded because menu prompting
 +	 is not used on replay.  */
 +      orig_defn_macro = KVAR (current_kboard, defining_kbd_macro);
 +      kset_defining_kbd_macro (current_kboard, Qnil);
 +      do
 +	obj = read_char (commandflag, Qnil, Qt, 0, NULL);
 +      while (BUFFERP (obj));
 +      kset_defining_kbd_macro (current_kboard, orig_defn_macro);
 +
 +      if (!INTEGERP (obj) || XINT (obj) == -2
 +	  || (! EQ (obj, menu_prompt_more_char)
 +	      && (!INTEGERP (menu_prompt_more_char)
 +		  || ! EQ (obj, make_number (Ctl (XINT (menu_prompt_more_char)))))))
 +	{
 +	  if (!NILP (KVAR (current_kboard, defining_kbd_macro)))
 +	    store_kbd_macro_char (obj);
 +	  return obj;
 +	}
 +      /* Help char - go round again.  */
 +    }
 +}
 +
 +/* Reading key sequences.  */
 +
 +static Lisp_Object
 +follow_key (Lisp_Object keymap, Lisp_Object key)
 +{
 +  return access_keymap (get_keymap (keymap, 0, 1),
 +			key, 1, 0, 1);
 +}
 +
 +static Lisp_Object
 +active_maps (Lisp_Object first_event)
 +{
 +  Lisp_Object position
 +    = CONSP (first_event) ? CAR_SAFE (XCDR (first_event)) : Qnil;
 +  return Fcons (Qkeymap, Fcurrent_active_maps (Qt, position));
 +}
 +
 +/* Structure used to keep track of partial application of key remapping
 +   such as Vfunction_key_map and Vkey_translation_map.  */
 +typedef struct keyremap
 +{
 +  /* This is the map originally specified for this use.  */
 +  Lisp_Object parent;
 +  /* This is a submap reached by looking up, in PARENT,
 +     the events from START to END.  */
 +  Lisp_Object map;
 +  /* Positions [START, END) in the key sequence buffer
 +     are the key that we have scanned so far.
 +     Those events are the ones that we will replace
 +     if PARENT maps them into a key sequence.  */
 +  int start, end;
 +} keyremap;
 +
 +/* Lookup KEY in MAP.
 +   MAP is a keymap mapping keys to key vectors or functions.
 +   If the mapping is a function and DO_FUNCALL is true,
 +   the function is called with PROMPT as parameter and its return
 +   value is used as the return value of this function (after checking
 +   that it is indeed a vector).  */
 +
 +static Lisp_Object
 +access_keymap_keyremap (Lisp_Object map, Lisp_Object key, Lisp_Object prompt,
 +			bool do_funcall)
 +{
 +  Lisp_Object next;
 +
 +  next = access_keymap (map, key, 1, 0, 1);
 +
 +  /* Handle a symbol whose function definition is a keymap
 +     or an array.  */
 +  if (SYMBOLP (next) && !NILP (Ffboundp (next))
 +      && (ARRAYP (XSYMBOL (next)->function)
 +	  || KEYMAPP (XSYMBOL (next)->function)))
 +    next = Fautoload_do_load (XSYMBOL (next)->function, next, Qnil);
 +
 +  /* If the keymap gives a function, not an
 +     array, then call the function with one arg and use
 +     its value instead.  */
 +  if (do_funcall && FUNCTIONP (next))
 +    {
 +      Lisp_Object tem;
 +      tem = next;
 +
 +      next = call1 (next, prompt);
 +      /* If the function returned something invalid,
 +	 barf--don't ignore it.
 +	 (To ignore it safely, we would need to gcpro a bunch of
 +	 other variables.)  */
 +      if (! (NILP (next) || VECTORP (next) || STRINGP (next)))
 +	error ("Function %s returns invalid key sequence",
 +	       SSDATA (SYMBOL_NAME (tem)));
 +    }
 +  return next;
 +}
 +
 +/* Do one step of the key remapping used for function-key-map and
 +   key-translation-map:
 +   KEYBUF is the buffer holding the input events.
 +   BUFSIZE is its maximum size.
 +   FKEY is a pointer to the keyremap structure to use.
 +   INPUT is the index of the last element in KEYBUF.
 +   DOIT if true says that the remapping can actually take place.
 +   DIFF is used to return the number of keys added/removed by the remapping.
 +   PARENT is the root of the keymap.
 +   PROMPT is the prompt to use if the remapping happens through a function.
 +   Return true if the remapping actually took place.  */
 +
 +static bool
 +keyremap_step (Lisp_Object *keybuf, int bufsize, volatile keyremap *fkey,
 +	       int input, bool doit, int *diff, Lisp_Object prompt)
 +{
 +  Lisp_Object next, key;
 +
 +  key = keybuf[fkey->end++];
 +
 +  if (KEYMAPP (fkey->parent))
 +    next = access_keymap_keyremap (fkey->map, key, prompt, doit);
 +  else
 +    next = Qnil;
 +
 +  /* If keybuf[fkey->start..fkey->end] is bound in the
 +     map and we're in a position to do the key remapping, replace it with
 +     the binding and restart with fkey->start at the end.  */
 +  if ((VECTORP (next) || STRINGP (next)) && doit)
 +    {
 +      int len = XFASTINT (Flength (next));
 +      int i;
 +
 +      *diff = len - (fkey->end - fkey->start);
 +
 +      if (bufsize - input <= *diff)
 +	error ("Key sequence too long");
 +
 +      /* Shift the keys that follow fkey->end.  */
 +      if (*diff < 0)
 +	for (i = fkey->end; i < input; i++)
 +	  keybuf[i + *diff] = keybuf[i];
 +      else if (*diff > 0)
 +	for (i = input - 1; i >= fkey->end; i--)
 +	  keybuf[i + *diff] = keybuf[i];
 +      /* Overwrite the old keys with the new ones.  */
 +      for (i = 0; i < len; i++)
 +	keybuf[fkey->start + i]
 +	  = Faref (next, make_number (i));
 +
 +      fkey->start = fkey->end += *diff;
 +      fkey->map = fkey->parent;
 +
 +      return 1;
 +    }
 +
 +  fkey->map = get_keymap (next, 0, 1);
 +
 +  /* If we no longer have a bound suffix, try a new position for
 +     fkey->start.  */
 +  if (!CONSP (fkey->map))
 +    {
 +      fkey->end = ++fkey->start;
 +      fkey->map = fkey->parent;
 +    }
 +  return 0;
 +}
 +
 +static bool
 +test_undefined (Lisp_Object binding)
 +{
 +  return (NILP (binding)
 +	  || EQ (binding, Qundefined)
 +	  || (SYMBOLP (binding)
 +	      && EQ (Fcommand_remapping (binding, Qnil, Qnil), Qundefined)));
 +}
 +
 +/* Read a sequence of keys that ends with a non prefix character,
 +   storing it in KEYBUF, a buffer of size BUFSIZE.
 +   Prompt with PROMPT.
 +   Return the length of the key sequence stored.
 +   Return -1 if the user rejected a command menu.
 +
 +   Echo starting immediately unless `prompt' is 0.
 +
 +   If PREVENT_REDISPLAY is non-zero, avoid redisplay by calling
 +   read_char with a suitable COMMANDFLAG argument.
 +
 +   Where a key sequence ends depends on the currently active keymaps.
 +   These include any minor mode keymaps active in the current buffer,
 +   the current buffer's local map, and the global map.
 +
 +   If a key sequence has no other bindings, we check Vfunction_key_map
 +   to see if some trailing subsequence might be the beginning of a
 +   function key's sequence.  If so, we try to read the whole function
 +   key, and substitute its symbolic name into the key sequence.
 +
 +   We ignore unbound `down-' mouse clicks.  We turn unbound `drag-' and
 +   `double-' events into similar click events, if that would make them
 +   bound.  We try to turn `triple-' events first into `double-' events,
 +   then into clicks.
 +
 +   If we get a mouse click in a mode line, vertical divider, or other
 +   non-text area, we treat the click as if it were prefixed by the
 +   symbol denoting that area - `mode-line', `vertical-line', or
 +   whatever.
 +
 +   If the sequence starts with a mouse click, we read the key sequence
 +   with respect to the buffer clicked on, not the current buffer.
 +
 +   If the user switches frames in the midst of a key sequence, we put
 +   off the switch-frame event until later; the next call to
 +   read_char will return it.
 +
 +   If FIX_CURRENT_BUFFER, we restore current_buffer
 +   from the selected window's buffer.  */
 +
 +static int
 +read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt,
 +		   bool dont_downcase_last, bool can_return_switch_frame,
 +		   bool fix_current_buffer, bool prevent_redisplay)
 +{
 +  ptrdiff_t count = SPECPDL_INDEX ();
 +
 +  /* How many keys there are in the current key sequence.  */
 +  int t;
 +
 +  /* The length of the echo buffer when we started reading, and
 +     the length of this_command_keys when we started reading.  */
 +  ptrdiff_t echo_start IF_LINT (= 0);
 +  ptrdiff_t keys_start;
 +
 +  Lisp_Object current_binding = Qnil;
 +  Lisp_Object first_event = Qnil;
 +
 +  /* Index of the first key that has no binding.
 +     It is useless to try fkey.start larger than that.  */
 +  int first_unbound;
 +
 +  /* If t < mock_input, then KEYBUF[t] should be read as the next
 +     input key.
 +
 +     We use this to recover after recognizing a function key.  Once we
 +     realize that a suffix of the current key sequence is actually a
 +     function key's escape sequence, we replace the suffix with the
 +     function key's binding from Vfunction_key_map.  Now keybuf
 +     contains a new and different key sequence, so the echo area,
 +     this_command_keys, and the submaps and defs arrays are wrong.  In
 +     this situation, we set mock_input to t, set t to 0, and jump to
 +     restart_sequence; the loop will read keys from keybuf up until
 +     mock_input, thus rebuilding the state; and then it will resume
 +     reading characters from the keyboard.  */
 +  int mock_input = 0;
 +
 +  /* If the sequence is unbound in submaps[], then
 +     keybuf[fkey.start..fkey.end-1] is a prefix in Vfunction_key_map,
 +     and fkey.map is its binding.
 +
 +     These might be > t, indicating that all function key scanning
 +     should hold off until t reaches them.  We do this when we've just
 +     recognized a function key, to avoid searching for the function
 +     key's again in Vfunction_key_map.  */
 +  keyremap fkey;
 +
 +  /* Likewise, for key_translation_map and input-decode-map.  */
 +  keyremap keytran, indec;
 +
 +  /* True if we are trying to map a key by changing an upper-case
 +     letter to lower case, or a shifted function key to an unshifted
 +     one.  */
 +  bool shift_translated = 0;
 +
 +  /* If we receive a `switch-frame' or `select-window' event in the middle of
 +     a key sequence, we put it off for later.
 +     While we're reading, we keep the event here.  */
 +  Lisp_Object delayed_switch_frame;
 +
 +  Lisp_Object original_uppercase IF_LINT (= Qnil);
 +  int original_uppercase_position = -1;
 +
 +  /* Gets around Microsoft compiler limitations.  */
 +  bool dummyflag = 0;
 +
 +  struct buffer *starting_buffer;
 +
 +  /* List of events for which a fake prefix key has been generated.  */
 +  Lisp_Object fake_prefixed_keys = Qnil;
 +
 +  struct gcpro gcpro1;
 +
 +  GCPRO1 (fake_prefixed_keys);
 +  raw_keybuf_count = 0;
 +
 +  last_nonmenu_event = Qnil;
 +
 +  delayed_switch_frame = Qnil;
 +
 +  if (INTERACTIVE)
 +    {
 +      if (!NILP (prompt))
 +	{
 +	  /* Install the string PROMPT as the beginning of the string
 +	     of echoing, so that it serves as a prompt for the next
 +	     character.  */
 +	  kset_echo_string (current_kboard, prompt);
 +	  current_kboard->echo_after_prompt = SCHARS (prompt);
 +	  echo_now ();
 +	}
 +      else if (cursor_in_echo_area
 +	       && echo_keystrokes_p ())
 +	/* This doesn't put in a dash if the echo buffer is empty, so
 +	   you don't always see a dash hanging out in the minibuffer.  */
 +	echo_dash ();
 +    }
 +
 +  /* Record the initial state of the echo area and this_command_keys;
 +     we will need to restore them if we replay a key sequence.  */
 +  if (INTERACTIVE)
 +    echo_start = echo_length ();
 +  keys_start = this_command_key_count;
 +  this_single_command_key_start = keys_start;
 +
 +  /* We jump here when we need to reinitialize fkey and keytran; this
 +     happens if we switch keyboards between rescans.  */
 + replay_entire_sequence:
 +
 +  indec.map = indec.parent = KVAR (current_kboard, Vinput_decode_map);
 +  fkey.map = fkey.parent = KVAR (current_kboard, Vlocal_function_key_map);
 +  keytran.map = keytran.parent = Vkey_translation_map;
 +  indec.start = indec.end = 0;
 +  fkey.start = fkey.end = 0;
 +  keytran.start = keytran.end = 0;
 +
 +  /* We jump here when the key sequence has been thoroughly changed, and
 +     we need to rescan it starting from the beginning.  When we jump here,
 +     keybuf[0..mock_input] holds the sequence we should reread.  */
 + replay_sequence:
 +
 +  starting_buffer = current_buffer;
 +  first_unbound = bufsize + 1;
 +
 +  /* Build our list of keymaps.
 +     If we recognize a function key and replace its escape sequence in
 +     keybuf with its symbol, or if the sequence starts with a mouse
 +     click and we need to switch buffers, we jump back here to rebuild
 +     the initial keymaps from the current buffer.  */
 +  current_binding = active_maps (first_event);
 +
 +  /* Start from the beginning in keybuf.  */
 +  t = 0;
 +
 +  /* These are no-ops the first time through, but if we restart, they
 +     revert the echo area and this_command_keys to their original state.  */
 +  this_command_key_count = keys_start;
 +  if (INTERACTIVE && t < mock_input)
 +    echo_truncate (echo_start);
 +
 +  /* If the best binding for the current key sequence is a keymap, or
 +     we may be looking at a function key's escape sequence, keep on
 +     reading.  */
 +  while (!NILP (current_binding)
 +	 /* Keep reading as long as there's a prefix binding.  */
 +	 ? KEYMAPP (current_binding)
 +	 /* Don't return in the middle of a possible function key sequence,
 +	    if the only bindings we found were via case conversion.
 +	    Thus, if ESC O a has a function-key-map translation
 +	    and ESC o has a binding, don't return after ESC O,
 +	    so that we can translate ESC O plus the next character.  */
 +	 : (/* indec.start < t || fkey.start < t || */ keytran.start < t))
 +    {
 +      Lisp_Object key;
 +      bool used_mouse_menu = 0;
 +
 +      /* Where the last real key started.  If we need to throw away a
 +         key that has expanded into more than one element of keybuf
 +         (say, a mouse click on the mode line which is being treated
 +         as [mode-line (mouse-...)], then we backtrack to this point
 +         of keybuf.  */
 +      int last_real_key_start;
 +
 +      /* These variables are analogous to echo_start and keys_start;
 +	 while those allow us to restart the entire key sequence,
 +	 echo_local_start and keys_local_start allow us to throw away
 +	 just one key.  */
 +      ptrdiff_t echo_local_start IF_LINT (= 0);
 +      int keys_local_start;
 +      Lisp_Object new_binding;
 +
 +      eassert (indec.end == t || (indec.end > t && indec.end <= mock_input));
 +      eassert (indec.start <= indec.end);
 +      eassert (fkey.start <= fkey.end);
 +      eassert (keytran.start <= keytran.end);
 +      /* key-translation-map is applied *after* function-key-map
 +	 which is itself applied *after* input-decode-map.  */
 +      eassert (fkey.end <= indec.start);
 +      eassert (keytran.end <= fkey.start);
 +
 +      if (/* first_unbound < indec.start && first_unbound < fkey.start && */
 +	  first_unbound < keytran.start)
 +	{ /* The prefix upto first_unbound has no binding and has
 +	     no translation left to do either, so we know it's unbound.
 +	     If we don't stop now, we risk staying here indefinitely
 +	     (if the user keeps entering fkey or keytran prefixes
 +	     like C-c ESC ESC ESC ESC ...)  */
 +	  int i;
 +	  for (i = first_unbound + 1; i < t; i++)
 +	    keybuf[i - first_unbound - 1] = keybuf[i];
 +	  mock_input = t - first_unbound - 1;
 +	  indec.end = indec.start -= first_unbound + 1;
 +	  indec.map = indec.parent;
 +	  fkey.end = fkey.start -= first_unbound + 1;
 +	  fkey.map = fkey.parent;
 +	  keytran.end = keytran.start -= first_unbound + 1;
 +	  keytran.map = keytran.parent;
 +	  goto replay_sequence;
 +	}
 +
 +      if (t >= bufsize)
 +	error ("Key sequence too long");
 +
 +      if (INTERACTIVE)
 +	echo_local_start = echo_length ();
 +      keys_local_start = this_command_key_count;
 +
 +    replay_key:
 +      /* These are no-ops, unless we throw away a keystroke below and
 +	 jumped back up to replay_key; in that case, these restore the
 +	 variables to their original state, allowing us to replay the
 +	 loop.  */
 +      if (INTERACTIVE && t < mock_input)
 +	echo_truncate (echo_local_start);
 +      this_command_key_count = keys_local_start;
 +
 +      /* By default, assume each event is "real".  */
 +      last_real_key_start = t;
 +
 +      /* Does mock_input indicate that we are re-reading a key sequence?  */
 +      if (t < mock_input)
 +	{
 +	  key = keybuf[t];
 +	  add_command_key (key);
 +	  if (echo_keystrokes_p ()
 +	      && current_kboard->immediate_echo)
 +	    {
 +	      echo_add_key (key);
 +	      echo_dash ();
 +	    }
 +	}
 +
 +      /* If not, we should actually read a character.  */
 +      else
 +	{
 +	  {
 +	    KBOARD *interrupted_kboard = current_kboard;
 +	    struct frame *interrupted_frame = SELECTED_FRAME ();
 +	    /* Calling read_char with COMMANDFLAG = -2 avoids
 +	       redisplay in read_char and its subroutines.  */
 +	    key = read_char (prevent_redisplay ? -2 : NILP (prompt),
 +		             current_binding, last_nonmenu_event,
 +                             &used_mouse_menu, NULL);
 +	    if ((INTEGERP (key) && XINT (key) == -2) /* wrong_kboard_jmpbuf */
 +		/* When switching to a new tty (with a new keyboard),
 +		   read_char returns the new buffer, rather than -2
 +		   (Bug#5095).  This is because `terminal-init-xterm'
 +		   calls read-char, which eats the wrong_kboard_jmpbuf
 +		   return.  Any better way to fix this? -- cyd  */
 +		|| (interrupted_kboard != current_kboard))
 +	      {
 +		bool found = 0;
 +		struct kboard *k;
 +
 +		for (k = all_kboards; k; k = k->next_kboard)
 +		  if (k == interrupted_kboard)
 +		    found = 1;
 +
 +		if (!found)
 +		  {
 +		    /* Don't touch interrupted_kboard when it's been
 +		       deleted.  */
 +		    delayed_switch_frame = Qnil;
 +		    goto replay_entire_sequence;
 +		  }
 +
 +		if (!NILP (delayed_switch_frame))
 +		  {
 +		    kset_kbd_queue
 +		      (interrupted_kboard,
 +		       Fcons (delayed_switch_frame,
 +			      KVAR (interrupted_kboard, kbd_queue)));
 +		    delayed_switch_frame = Qnil;
 +		  }
 +
 +		while (t > 0)
 +		  kset_kbd_queue
 +		    (interrupted_kboard,
 +		     Fcons (keybuf[--t], KVAR (interrupted_kboard, kbd_queue)));
 +
 +		/* If the side queue is non-empty, ensure it begins with a
 +		   switch-frame, so we'll replay it in the right context.  */
 +		if (CONSP (KVAR (interrupted_kboard, kbd_queue))
 +		    && (key = XCAR (KVAR (interrupted_kboard, kbd_queue)),
 +			!(EVENT_HAS_PARAMETERS (key)
 +			  && EQ (EVENT_HEAD_KIND (EVENT_HEAD (key)),
 +				 Qswitch_frame))))
 +		  {
 +		    Lisp_Object frame;
 +		    XSETFRAME (frame, interrupted_frame);
 +		    kset_kbd_queue
 +		      (interrupted_kboard,
 +		       Fcons (make_lispy_switch_frame (frame),
 +			      KVAR (interrupted_kboard, kbd_queue)));
 +		  }
 +		mock_input = 0;
 +		goto replay_entire_sequence;
 +	      }
 +	  }
 +
 +	  /* read_char returns t when it shows a menu and the user rejects it.
 +	     Just return -1.  */
 +	  if (EQ (key, Qt))
 +	    {
 +	      unbind_to (count, Qnil);
 +	      UNGCPRO;
 +	      return -1;
 +	    }
 +
 +	  /* read_char returns -1 at the end of a macro.
 +	     Emacs 18 handles this by returning immediately with a
 +	     zero, so that's what we'll do.  */
 +	  if (INTEGERP (key) && XINT (key) == -1)
 +	    {
 +	      t = 0;
 +	      /* The Microsoft C compiler can't handle the goto that
 +		 would go here.  */
 +	      dummyflag = 1;
 +	      break;
 +	    }
 +
 +	  /* If the current buffer has been changed from under us, the
 +	     keymap may have changed, so replay the sequence.  */
 +	  if (BUFFERP (key))
 +	    {
 +	      timer_resume_idle ();
 +
 +	      mock_input = t;
 +	      /* Reset the current buffer from the selected window
 +		 in case something changed the former and not the latter.
 +		 This is to be more consistent with the behavior
 +		 of the command_loop_1.  */
 +	      if (fix_current_buffer)
 +		{
 +		  if (! FRAME_LIVE_P (XFRAME (selected_frame)))
 +		    Fkill_emacs (Qnil);
 +		  if (XBUFFER (XWINDOW (selected_window)->contents)
 +		      != current_buffer)
 +		    Fset_buffer (XWINDOW (selected_window)->contents);
 +		}
 +
 +	      goto replay_sequence;
 +	    }
 +
 +	  /* If we have a quit that was typed in another frame, and
 +	     quit_throw_to_read_char switched buffers,
 +	     replay to get the right keymap.  */
 +	  if (INTEGERP (key)
 +	      && XINT (key) == quit_char
 +	      && current_buffer != starting_buffer)
 +	    {
 +	      GROW_RAW_KEYBUF;
 +	      ASET (raw_keybuf, raw_keybuf_count, key);
 +	      raw_keybuf_count++;
 +	      keybuf[t++] = key;
 +	      mock_input = t;
 +	      Vquit_flag = Qnil;
 +	      goto replay_sequence;
 +	    }
 +
 +	  Vquit_flag = Qnil;
 +
 +	  if (EVENT_HAS_PARAMETERS (key)
 +	      /* Either a `switch-frame' or a `select-window' event.  */
 +	      && EQ (EVENT_HEAD_KIND (EVENT_HEAD (key)), Qswitch_frame))
 +	    {
 +	      /* If we're at the beginning of a key sequence, and the caller
 +		 says it's okay, go ahead and return this event.  If we're
 +		 in the midst of a key sequence, delay it until the end.  */
 +	      if (t > 0 || !can_return_switch_frame)
 +		{
 +		  delayed_switch_frame = key;
 +		  goto replay_key;
 +		}
 +	    }
 +
 +	  if (NILP (first_event))
 +	    {
 +	      first_event = key;
 +	      /* Even if first_event does not specify a particular
 +		 window/position, it's important to recompute the maps here
 +		 since a long time might have passed since we entered
 +		 read_key_sequence, and a timer (or process-filter or
 +		 special-event-map, ...) might have switched the current buffer
 +		 or the selected window from under us in the mean time.  */
 +	      if (fix_current_buffer
 +		  && (XBUFFER (XWINDOW (selected_window)->contents)
 +		      != current_buffer))
 +		Fset_buffer (XWINDOW (selected_window)->contents);
 +	      current_binding = active_maps (first_event);
 +	    }
 +
 +	  GROW_RAW_KEYBUF;
 +	  ASET (raw_keybuf, raw_keybuf_count, key);
 +	  raw_keybuf_count++;
 +	}
 +
 +      /* Clicks in non-text areas get prefixed by the symbol
 +	 in their CHAR-ADDRESS field.  For example, a click on
 +	 the mode line is prefixed by the symbol `mode-line'.
 +
 +	 Furthermore, key sequences beginning with mouse clicks
 +	 are read using the keymaps of the buffer clicked on, not
 +	 the current buffer.  So we may have to switch the buffer
 +	 here.
 +
 +	 When we turn one event into two events, we must make sure
 +	 that neither of the two looks like the original--so that,
 +	 if we replay the events, they won't be expanded again.
 +	 If not for this, such reexpansion could happen either here
 +	 or when user programs play with this-command-keys.  */
 +      if (EVENT_HAS_PARAMETERS (key))
 +	{
 +	  Lisp_Object kind = EVENT_HEAD_KIND (EVENT_HEAD (key));
 +	  if (EQ (kind, Qmouse_click))
 +	    {
 +	      Lisp_Object window = POSN_WINDOW (EVENT_START (key));
 +	      Lisp_Object posn = POSN_POSN (EVENT_START (key));
 +
 +	      if (CONSP (posn)
 +		  || (!NILP (fake_prefixed_keys)
 +		      && !NILP (Fmemq (key, fake_prefixed_keys))))
 +		{
 +		  /* We're looking a second time at an event for which
 +		     we generated a fake prefix key.  Set
 +		     last_real_key_start appropriately.  */
 +		  if (t > 0)
 +		    last_real_key_start = t - 1;
 +		}
 +
 +	      if (last_real_key_start == 0)
 +		{
 +		  /* Key sequences beginning with mouse clicks are
 +		     read using the keymaps in the buffer clicked on,
 +		     not the current buffer.  If we're at the
 +		     beginning of a key sequence, switch buffers.  */
 +		  if (WINDOWP (window)
 +		      && BUFFERP (XWINDOW (window)->contents)
 +		      && XBUFFER (XWINDOW (window)->contents) != current_buffer)
 +		    {
 +		      ASET (raw_keybuf, raw_keybuf_count, key);
 +		      raw_keybuf_count++;
 +		      keybuf[t] = key;
 +		      mock_input = t + 1;
 +
 +		      /* Arrange to go back to the original buffer once we're
 +			 done reading the key sequence.  Note that we can't
 +			 use save_excursion_{save,restore} here, because they
 +			 save point as well as the current buffer; we don't
 +			 want to save point, because redisplay may change it,
 +			 to accommodate a Fset_window_start or something.  We
 +			 don't want to do this at the top of the function,
 +			 because we may get input from a subprocess which
 +			 wants to change the selected window and stuff (say,
 +			 emacsclient).  */
 +		      record_unwind_current_buffer ();
 +
 +		      if (! FRAME_LIVE_P (XFRAME (selected_frame)))
 +			Fkill_emacs (Qnil);
 +		      set_buffer_internal (XBUFFER (XWINDOW (window)->contents));
 +		      goto replay_sequence;
 +		    }
 +		}
 +
 +	      /* Expand mode-line and scroll-bar events into two events:
 +		 use posn as a fake prefix key.  */
 +	      if (SYMBOLP (posn)
 +		  && (NILP (fake_prefixed_keys)
 +		      || NILP (Fmemq (key, fake_prefixed_keys))))
 +		{
 +		  if (bufsize - t <= 1)
 +		    error ("Key sequence too long");
 +
 +		  keybuf[t]     = posn;
 +		  keybuf[t + 1] = key;
 +		  mock_input    = t + 2;
 +
 +		  /* Record that a fake prefix key has been generated
 +		     for KEY.  Don't modify the event; this would
 +		     prevent proper action when the event is pushed
 +		     back into unread-command-events.  */
 +		  fake_prefixed_keys = Fcons (key, fake_prefixed_keys);
 +		  goto replay_key;
 +		}
 +	    }
 +	  else if (CONSP (XCDR (key))
 +		   && CONSP (EVENT_START (key))
 +		   && CONSP (XCDR (EVENT_START (key))))
 +	    {
 +	      Lisp_Object posn;
 +
 +	      posn = POSN_POSN (EVENT_START (key));
 +	      /* Handle menu-bar events:
 +		 insert the dummy prefix event `menu-bar'.  */
 +	      if (EQ (posn, Qmenu_bar) || EQ (posn, Qtool_bar))
 +		{
 +		  if (bufsize - t <= 1)
 +		    error ("Key sequence too long");
 +		  keybuf[t] = posn;
 +		  keybuf[t + 1] = key;
 +
 +		  /* Zap the position in key, so we know that we've
 +		     expanded it, and don't try to do so again.  */
 +		  POSN_SET_POSN (EVENT_START (key), list1 (posn));
 +
 +		  mock_input = t + 2;
 +		  goto replay_sequence;
 +		}
 +	      else if (CONSP (posn))
 +		{
 +		  /* We're looking at the second event of a
 +		     sequence which we expanded before.  Set
 +		     last_real_key_start appropriately.  */
 +		  if (last_real_key_start == t && t > 0)
 +		    last_real_key_start = t - 1;
 +		}
 +	    }
 +	}
 +
 +      /* We have finally decided that KEY is something we might want
 +	 to look up.  */
 +      new_binding = follow_key (current_binding, key);
 +
 +      /* If KEY wasn't bound, we'll try some fallbacks.  */
 +      if (!NILP (new_binding))
 +	/* This is needed for the following scenario:
 +	   event 0: a down-event that gets dropped by calling replay_key.
 +	   event 1: some normal prefix like C-h.
 +	   After event 0, first_unbound is 0, after event 1 indec.start,
 +	   fkey.start, and keytran.start are all 1, so when we see that
 +	   C-h is bound, we need to update first_unbound.  */
 +	first_unbound = max (t + 1, first_unbound);
 +      else
 +	{
 +	  Lisp_Object head;
 +
 +	  /* Remember the position to put an upper bound on indec.start.  */
 +	  first_unbound = min (t, first_unbound);
 +
 +	  head = EVENT_HEAD (key);
 +
 +	  if (SYMBOLP (head))
 +	    {
 +	      Lisp_Object breakdown;
 +	      int modifiers;
 +
 +	      breakdown = parse_modifiers (head);
 +	      modifiers = XINT (XCAR (XCDR (breakdown)));
 +	      /* Attempt to reduce an unbound mouse event to a simpler
 +		 event that is bound:
 +		   Drags reduce to clicks.
 +		   Double-clicks reduce to clicks.
 +		   Triple-clicks reduce to double-clicks, then to clicks.
 +		   Down-clicks are eliminated.
 +		   Double-downs reduce to downs, then are eliminated.
 +		   Triple-downs reduce to double-downs, then to downs,
 +		     then are eliminated.  */
 +	      if (modifiers & (down_modifier | drag_modifier
 +			       | double_modifier | triple_modifier))
 +		{
 +		  while (modifiers & (down_modifier | drag_modifier
 +				      | double_modifier | triple_modifier))
 +		    {
 +		      Lisp_Object new_head, new_click;
 +		      if (modifiers & triple_modifier)
 +			modifiers ^= (double_modifier | triple_modifier);
 +		      else if (modifiers & double_modifier)
 +			modifiers &= ~double_modifier;
 +		      else if (modifiers & drag_modifier)
 +			modifiers &= ~drag_modifier;
 +		      else
 +			{
 +			  /* Dispose of this `down' event by simply jumping
 +			     back to replay_key, to get another event.
 +
 +			     Note that if this event came from mock input,
 +			     then just jumping back to replay_key will just
 +			     hand it to us again.  So we have to wipe out any
 +			     mock input.
 +
 +			     We could delete keybuf[t] and shift everything
 +			     after that to the left by one spot, but we'd also
 +			     have to fix up any variable that points into
 +			     keybuf, and shifting isn't really necessary
 +			     anyway.
 +
 +			     Adding prefixes for non-textual mouse clicks
 +			     creates two characters of mock input, and both
 +			     must be thrown away.  If we're only looking at
 +			     the prefix now, we can just jump back to
 +			     replay_key.  On the other hand, if we've already
 +			     processed the prefix, and now the actual click
 +			     itself is giving us trouble, then we've lost the
 +			     state of the keymaps we want to backtrack to, and
 +			     we need to replay the whole sequence to rebuild
 +			     it.
 +
 +			     Beyond that, only function key expansion could
 +			     create more than two keys, but that should never
 +			     generate mouse events, so it's okay to zero
 +			     mock_input in that case too.
 +
 +			     FIXME: The above paragraph seems just plain
 +			     wrong, if you consider things like
 +			     xterm-mouse-mode.  -stef
 +
 +			     Isn't this just the most wonderful code ever?  */
 +
 +			  /* If mock_input > t + 1, the above simplification
 +			     will actually end up dropping keys on the floor.
 +			     This is probably OK for now, but even
 +			     if mock_input <= t + 1, we need to adjust indec,
 +			     fkey, and keytran.
 +			     Typical case [header-line down-mouse-N]:
 +			     mock_input = 2, t = 1, fkey.end = 1,
 +			     last_real_key_start = 0.  */
 +			  if (indec.end > last_real_key_start)
 +			    {
 +			      indec.end = indec.start
 +				= min (last_real_key_start, indec.start);
 +			      indec.map = indec.parent;
 +			      if (fkey.end > last_real_key_start)
 +				{
 +				  fkey.end = fkey.start
 +				    = min (last_real_key_start, fkey.start);
 +				  fkey.map = fkey.parent;
 +				  if (keytran.end > last_real_key_start)
 +				    {
 +				      keytran.end = keytran.start
 +					= min (last_real_key_start, keytran.start);
 +				      keytran.map = keytran.parent;
 +				    }
 +				}
 +			    }
 +			  if (t == last_real_key_start)
 +			    {
 +			      mock_input = 0;
 +			      goto replay_key;
 +			    }
 +			  else
 +			    {
 +			      mock_input = last_real_key_start;
 +			      goto replay_sequence;
 +			    }
 +			}
 +
 +		      new_head
 +			= apply_modifiers (modifiers, XCAR (breakdown));
 +		      new_click = list2 (new_head, EVENT_START (key));
 +
 +		      /* Look for a binding for this new key.  */
 +		      new_binding = follow_key (current_binding, new_click);
 +
 +		      /* If that click is bound, go for it.  */
 +		      if (!NILP (new_binding))
 +			{
 +			  current_binding = new_binding;
 +			  key = new_click;
 +			  break;
 +			}
 +		      /* Otherwise, we'll leave key set to the drag event.  */
 +		    }
 +		}
 +	    }
 +	}
 +      current_binding = new_binding;
 +
 +      keybuf[t++] = key;
 +      /* Normally, last_nonmenu_event gets the previous key we read.
 +	 But when a mouse popup menu is being used,
 +	 we don't update last_nonmenu_event; it continues to hold the mouse
 +	 event that preceded the first level of menu.  */
 +      if (!used_mouse_menu)
 +	last_nonmenu_event = key;
 +
 +      /* Record what part of this_command_keys is the current key sequence.  */
 +      this_single_command_key_start = this_command_key_count - t;
 +      /* When 'input-method-function' called above causes events to be
 +	 put on 'unread-post-input-method-events', and as result
 +	 'reread' is set to 'true', the value of 't' can become larger
 +	 than 'this_command_key_count', because 'add_command_key' is
 +	 not called to update 'this_command_key_count'.  If this
 +	 happens, 'this_single_command_key_start' will become negative
 +	 above, and any call to 'this-single-command-keys' will return
 +	 a garbled vector.  See bug #20223 for one such situation.
 +	 Here we force 'this_single_command_key_start' to never become
 +	 negative, to avoid that.  */
 +      if (this_single_command_key_start < 0)
 +	this_single_command_key_start = 0;
 +
 +      /* Look for this sequence in input-decode-map.
 +	 Scan from indec.end until we find a bound suffix.  */
 +      while (indec.end < t)
 +	{
 +	  struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 +	  bool done;
 +	  int diff;
 +
 +	  GCPRO4 (indec.map, fkey.map, keytran.map, delayed_switch_frame);
 +	  done = keyremap_step (keybuf, bufsize, &indec, max (t, mock_input),
 +				1, &diff, prompt);
 +	  UNGCPRO;
 +	  if (done)
 +	    {
 +	      mock_input = diff + max (t, mock_input);
 +	      goto replay_sequence;
 +	    }
 +	}
 +
 +      if (!KEYMAPP (current_binding)
 +	  && !test_undefined (current_binding)
 +	  && indec.start >= t)
 +	/* There is a binding and it's not a prefix.
 +	   (and it doesn't have any input-decode-map translation pending).
 +	   There is thus no function-key in this sequence.
 +	   Moving fkey.start is important in this case to allow keytran.start
 +	   to go over the sequence before we return (since we keep the
 +	   invariant that keytran.end <= fkey.start).  */
 +	{
 +	  if (fkey.start < t)
 +	    (fkey.start = fkey.end = t, fkey.map = fkey.parent);
 +	}
 +      else
 +	/* If the sequence is unbound, see if we can hang a function key
 +	   off the end of it.  */
 +	/* Continue scan from fkey.end until we find a bound suffix.  */
 +	while (fkey.end < indec.start)
 +	  {
 +	    struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 +	    bool done;
 +	    int diff;
 +
 +	    GCPRO4 (indec.map, fkey.map, keytran.map, delayed_switch_frame);
 +	    done = keyremap_step (keybuf, bufsize, &fkey,
 +				  max (t, mock_input),
 +				  /* If there's a binding (i.e.
 +				     first_binding >= nmaps) we don't want
 +				     to apply this function-key-mapping.  */
 +				  fkey.end + 1 == t
 +				  && (test_undefined (current_binding)),
 +				  &diff, prompt);
 +	    UNGCPRO;
 +	    if (done)
 +	      {
 +		mock_input = diff + max (t, mock_input);
 +		/* Adjust the input-decode-map counters.  */
 +		indec.end += diff;
 +		indec.start += diff;
 +
 +		goto replay_sequence;
 +	      }
 +	  }
 +
 +      /* Look for this sequence in key-translation-map.
 +	 Scan from keytran.end until we find a bound suffix.  */
 +      while (keytran.end < fkey.start)
 +	{
 +	  struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 +	  bool done;
 +	  int diff;
 +
 +	  GCPRO4 (indec.map, fkey.map, keytran.map, delayed_switch_frame);
 +	  done = keyremap_step (keybuf, bufsize, &keytran, max (t, mock_input),
 +				1, &diff, prompt);
 +	  UNGCPRO;
 +	  if (done)
 +	    {
 +	      mock_input = diff + max (t, mock_input);
 +	      /* Adjust the function-key-map and input-decode-map counters.  */
 +	      indec.end += diff;
 +	      indec.start += diff;
 +	      fkey.end += diff;
 +	      fkey.start += diff;
 +
 +	      goto replay_sequence;
 +	    }
 +	}
 +
 +      /* If KEY is not defined in any of the keymaps,
 +	 and cannot be part of a function key or translation,
 +	 and is an upper case letter
 +	 use the corresponding lower-case letter instead.  */
 +      if (NILP (current_binding)
 +	  && /* indec.start >= t && fkey.start >= t && */ keytran.start >= t
 +	  && INTEGERP (key)
 +	  && ((CHARACTERP (make_number (XINT (key) & ~CHAR_MODIFIER_MASK))
 +	       && uppercasep (XINT (key) & ~CHAR_MODIFIER_MASK))
 +	      || (XINT (key) & shift_modifier)))
 +	{
 +	  Lisp_Object new_key;
 +
 +	  original_uppercase = key;
 +	  original_uppercase_position = t - 1;
 +
 +	  if (XINT (key) & shift_modifier)
 +	    XSETINT (new_key, XINT (key) & ~shift_modifier);
 +	  else
 +	    XSETINT (new_key, (downcase (XINT (key) & ~CHAR_MODIFIER_MASK)
 +			       | (XINT (key) & CHAR_MODIFIER_MASK)));
 +
 +	  /* We have to do this unconditionally, regardless of whether
 +	     the lower-case char is defined in the keymaps, because they
 +	     might get translated through function-key-map.  */
 +	  keybuf[t - 1] = new_key;
 +	  mock_input = max (t, mock_input);
 +	  shift_translated = 1;
 +
 +	  goto replay_sequence;
 +	}
 +
 +      if (NILP (current_binding)
 +	  && help_char_p (EVENT_HEAD (key)) && t > 1)
 +	    {
 +	      read_key_sequence_cmd = Vprefix_help_command;
 +	      /* The Microsoft C compiler can't handle the goto that
 +		 would go here.  */
 +	      dummyflag = 1;
 +	      break;
 +	    }
 +
 +      /* If KEY is not defined in any of the keymaps,
 +	 and cannot be part of a function key or translation,
 +	 and is a shifted function key,
 +	 use the corresponding unshifted function key instead.  */
 +      if (NILP (current_binding)
 +	  && /* indec.start >= t && fkey.start >= t && */ keytran.start >= t)
 +	{
 +	  Lisp_Object breakdown = parse_modifiers (key);
 +	  int modifiers
 +	    = CONSP (breakdown) ? (XINT (XCAR (XCDR (breakdown)))) : 0;
 +
 +	  if (modifiers & shift_modifier
 +	      /* Treat uppercase keys as shifted.  */
 +	      || (INTEGERP (key)
 +		  && (KEY_TO_CHAR (key)
 +		      < XCHAR_TABLE (BVAR (current_buffer, downcase_table))->header.size)
 +		  && uppercasep (KEY_TO_CHAR (key))))
 +	    {
 +	      Lisp_Object new_key
 +		= (modifiers & shift_modifier
 +		   ? apply_modifiers (modifiers & ~shift_modifier,
 +				      XCAR (breakdown))
 +		   : make_number (downcase (KEY_TO_CHAR (key)) | modifiers));
 +
 +	      original_uppercase = key;
 +	      original_uppercase_position = t - 1;
 +
 +	      /* We have to do this unconditionally, regardless of whether
 +		 the lower-case char is defined in the keymaps, because they
 +		 might get translated through function-key-map.  */
 +	      keybuf[t - 1] = new_key;
 +	      mock_input = max (t, mock_input);
 +	      /* Reset fkey (and consequently keytran) to apply
 +		 function-key-map on the result, so that S-backspace is
 +		 correctly mapped to DEL (via backspace).  OTOH,
 +		 input-decode-map doesn't need to go through it again.  */
 +	      fkey.start = fkey.end = 0;
 +	      keytran.start = keytran.end = 0;
 +	      shift_translated = 1;
 +
 +	      goto replay_sequence;
 +	    }
 +	}
 +    }
 +  if (!dummyflag)
 +    read_key_sequence_cmd = current_binding;
 +  read_key_sequence_remapped
 +    /* Remap command through active keymaps.
 +       Do the remapping here, before the unbind_to so it uses the keymaps
 +       of the appropriate buffer.  */
 +    = SYMBOLP (read_key_sequence_cmd)
 +    ? Fcommand_remapping (read_key_sequence_cmd, Qnil, Qnil)
 +    : Qnil;
 +
 +  unread_switch_frame = delayed_switch_frame;
 +  unbind_to (count, Qnil);
 +
 +  /* Don't downcase the last character if the caller says don't.
 +     Don't downcase it if the result is undefined, either.  */
 +  if ((dont_downcase_last || NILP (current_binding))
 +      && t > 0
 +      && t - 1 == original_uppercase_position)
 +    {
 +      keybuf[t - 1] = original_uppercase;
 +      shift_translated = 0;
 +    }
 +
 +  if (shift_translated)
 +    Vthis_command_keys_shift_translated = Qt;
 +
 +  /* Occasionally we fabricate events, perhaps by expanding something
 +     according to function-key-map, or by adding a prefix symbol to a
 +     mouse click in the scroll bar or modeline.  In this cases, return
 +     the entire generated key sequence, even if we hit an unbound
 +     prefix or a definition before the end.  This means that you will
 +     be able to push back the event properly, and also means that
 +     read-key-sequence will always return a logical unit.
 +
 +     Better ideas?  */
 +  for (; t < mock_input; t++)
 +    {
 +      if (echo_keystrokes_p ())
 +	echo_char (keybuf[t]);
 +      add_command_key (keybuf[t]);
 +    }
 +
 +  UNGCPRO;
 +  return t;
 +}
 +
 +static Lisp_Object
 +read_key_sequence_vs (Lisp_Object prompt, Lisp_Object continue_echo,
 +		      Lisp_Object dont_downcase_last,
 +		      Lisp_Object can_return_switch_frame,
 +		      Lisp_Object cmd_loop, bool allow_string)
 +{
 +  Lisp_Object keybuf[30];
 +  register int i;
 +  struct gcpro gcpro1;
 +  ptrdiff_t count = SPECPDL_INDEX ();
 +
 +  if (!NILP (prompt))
 +    CHECK_STRING (prompt);
 +  QUIT;
 +
 +  specbind (Qinput_method_exit_on_first_char,
 +	    (NILP (cmd_loop) ? Qt : Qnil));
 +  specbind (Qinput_method_use_echo_area,
 +	    (NILP (cmd_loop) ? Qt : Qnil));
 +
 +  memset (keybuf, 0, sizeof keybuf);
 +  GCPRO1 (keybuf[0]);
 +  gcpro1.nvars = ARRAYELTS (keybuf);
 +
 +  if (NILP (continue_echo))
 +    {
 +      this_command_key_count = 0;
 +      this_command_key_count_reset = 0;
 +      this_single_command_key_start = 0;
 +    }
 +
 +#ifdef HAVE_WINDOW_SYSTEM
 +  if (display_hourglass_p)
 +    cancel_hourglass ();
 +#endif
 +
 +  i = read_key_sequence (keybuf, ARRAYELTS (keybuf),
 +			 prompt, ! NILP (dont_downcase_last),
 +			 ! NILP (can_return_switch_frame), 0, 0);
 +
 +#if 0  /* The following is fine for code reading a key sequence and
 +	  then proceeding with a lengthy computation, but it's not good
 +	  for code reading keys in a loop, like an input method.  */
 +#ifdef HAVE_WINDOW_SYSTEM
 +  if (display_hourglass_p)
 +    start_hourglass ();
 +#endif
 +#endif
 +
 +  if (i == -1)
 +    {
 +      Vquit_flag = Qt;
 +      QUIT;
 +    }
 +  UNGCPRO;
 +  return unbind_to (count,
 +		    ((allow_string ? make_event_array : Fvector)
 +		     (i, keybuf)));
 +}
 +
 +DEFUN ("read-key-sequence", Fread_key_sequence, Sread_key_sequence, 1, 5, 0,
 +       doc: /* Read a sequence of keystrokes and return as a string or vector.
 +The sequence is sufficient to specify a non-prefix command in the
 +current local and global maps.
 +
 +First arg PROMPT is a prompt string.  If nil, do not prompt specially.
 +Second (optional) arg CONTINUE-ECHO, if non-nil, means this key echos
 +as a continuation of the previous key.
 +
 +The third (optional) arg DONT-DOWNCASE-LAST, if non-nil, means do not
 +convert the last event to lower case.  (Normally any upper case event
 +is converted to lower case if the original event is undefined and the lower
 +case equivalent is defined.)  A non-nil value is appropriate for reading
 +a key sequence to be defined.
 +
 +A C-g typed while in this function is treated like any other character,
 +and `quit-flag' is not set.
 +
 +If the key sequence starts with a mouse click, then the sequence is read
 +using the keymaps of the buffer of the window clicked in, not the buffer
 +of the selected window as normal.
 +
 +`read-key-sequence' drops unbound button-down events, since you normally
 +only care about the click or drag events which follow them.  If a drag
 +or multi-click event is unbound, but the corresponding click event would
 +be bound, `read-key-sequence' turns the event into a click event at the
 +drag's starting position.  This means that you don't have to distinguish
 +between click and drag, double, or triple events unless you want to.
 +
 +`read-key-sequence' prefixes mouse events on mode lines, the vertical
 +lines separating windows, and scroll bars with imaginary keys
 +`mode-line', `vertical-line', and `vertical-scroll-bar'.
 +
 +Optional fourth argument CAN-RETURN-SWITCH-FRAME non-nil means that this
 +function will process a switch-frame event if the user switches frames
 +before typing anything.  If the user switches frames in the middle of a
 +key sequence, or at the start of the sequence but CAN-RETURN-SWITCH-FRAME
 +is nil, then the event will be put off until after the current key sequence.
 +
 +`read-key-sequence' checks `function-key-map' for function key
 +sequences, where they wouldn't conflict with ordinary bindings.  See
 +`function-key-map' for more details.
 +
 +The optional fifth argument CMD-LOOP, if non-nil, means
 +that this key sequence is being read by something that will
 +read commands one after another.  It should be nil if the caller
 +will read just one key sequence.  */)
 +  (Lisp_Object prompt, Lisp_Object continue_echo, Lisp_Object dont_downcase_last, Lisp_Object can_return_switch_frame, Lisp_Object cmd_loop)
 +{
 +  return read_key_sequence_vs (prompt, continue_echo, dont_downcase_last,
 +			       can_return_switch_frame, cmd_loop, true);
 +}
 +
 +DEFUN ("read-key-sequence-vector", Fread_key_sequence_vector,
 +       Sread_key_sequence_vector, 1, 5, 0,
 +       doc: /* Like `read-key-sequence' but always return a vector.  */)
 +  (Lisp_Object prompt, Lisp_Object continue_echo, Lisp_Object dont_downcase_last, Lisp_Object can_return_switch_frame, Lisp_Object cmd_loop)
 +{
 +  return read_key_sequence_vs (prompt, continue_echo, dont_downcase_last,
 +			       can_return_switch_frame, cmd_loop, false);
 +}
 +
 +/* Return true if input events are pending.  */
 +
 +bool
 +detect_input_pending (void)
 +{
 +  return input_pending || get_input_pending (0);
 +}
 +
 +/* Return true if input events other than mouse movements are
 +   pending.  */
 +
 +bool
 +detect_input_pending_ignore_squeezables (void)
 +{
 +  return input_pending || get_input_pending (READABLE_EVENTS_IGNORE_SQUEEZABLES);
 +}
 +
 +/* Return true if input events are pending, and run any pending timers.  */
 +
 +bool
 +detect_input_pending_run_timers (bool do_display)
 +{
 +  unsigned old_timers_run = timers_run;
 +
 +  if (!input_pending)
 +    get_input_pending (READABLE_EVENTS_DO_TIMERS_NOW);
 +
 +  if (old_timers_run != timers_run && do_display)
 +    redisplay_preserve_echo_area (8);
 +
 +  return input_pending;
 +}
 +
 +/* This is called in some cases before a possible quit.
 +   It cases the next call to detect_input_pending to recompute input_pending.
 +   So calling this function unnecessarily can't do any harm.  */
 +
 +void
 +clear_input_pending (void)
 +{
 +  input_pending = 0;
 +}
 +
 +/* Return true if there are pending requeued events.
 +   This isn't used yet.  The hope is to make wait_reading_process_output
 +   call it, and return if it runs Lisp code that unreads something.
 +   The problem is, kbd_buffer_get_event needs to be fixed to know what
 +   to do in that case.  It isn't trivial.  */
 +
 +bool
 +requeued_events_pending_p (void)
 +{
 +  return (!NILP (Vunread_command_events));
 +}
 +
 +DEFUN ("input-pending-p", Finput_pending_p, Sinput_pending_p, 0, 1, 0,
 +       doc: /* Return t if command input is currently available with no wait.
 +Actually, the value is nil only if we can be sure that no input is available;
 +if there is a doubt, the value is t.
 +
 +If CHECK-TIMERS is non-nil, timers that are ready to run will do so.  */)
 +  (Lisp_Object check_timers)
 +{
 +  if (!NILP (Vunread_command_events)
 +      || !NILP (Vunread_post_input_method_events)
 +      || !NILP (Vunread_input_method_events))
 +    return (Qt);
 +
 +  /* Process non-user-visible events (Bug#10195).  */
 +  process_special_events ();
 +
 +  return (get_input_pending ((NILP (check_timers)
 +                              ? 0 : READABLE_EVENTS_DO_TIMERS_NOW)
 +			     | READABLE_EVENTS_FILTER_EVENTS)
 +	  ? Qt : Qnil);
 +}
 +
 +DEFUN ("recent-keys", Frecent_keys, Srecent_keys, 0, 1, 0,
 +       doc: /* Return vector of last few events, not counting those from keyboard macros.
 +If INCLUDE-CMDS is non-nil, include the commands that were run,
 +represented as events of the form (nil . COMMAND).  */)
 +  (Lisp_Object include_cmds)
 +{
 +  bool cmds = !NILP (include_cmds);
 +
 +  if (!total_keys
 +      || (cmds && total_keys < NUM_RECENT_KEYS))
 +    return Fvector (total_keys,
 +		    XVECTOR (recent_keys)->contents);
 +  else
 +    {
 +      Lisp_Object es = Qnil;
 +      int i = (total_keys < NUM_RECENT_KEYS
 +	       ? 0 : recent_keys_index);
 +      eassert (recent_keys_index < NUM_RECENT_KEYS);
 +      do
 +	{
 +	  Lisp_Object e = AREF (recent_keys, i);
 +	  if (cmds || !CONSP (e) || !NILP (XCAR (e)))
 +	    es = Fcons (e, es);
 +	  if (++i >= NUM_RECENT_KEYS)
 +	    i = 0;
 +	} while (i != recent_keys_index);
 +      es = Fnreverse (es);
 +      return Fvconcat (1, &es);
 +    }
 +}
 +
 +DEFUN ("this-command-keys", Fthis_command_keys, Sthis_command_keys, 0, 0, 0,
 +       doc: /* Return the key sequence that invoked this command.
 +However, if the command has called `read-key-sequence', it returns
 +the last key sequence that has been read.
 +The value is a string or a vector.
 +
 +See also `this-command-keys-vector'.  */)
 +  (void)
 +{
 +  return make_event_array (this_command_key_count,
 +			   XVECTOR (this_command_keys)->contents);
 +}
 +
 +DEFUN ("this-command-keys-vector", Fthis_command_keys_vector, Sthis_command_keys_vector, 0, 0, 0,
 +       doc: /* Return the key sequence that invoked this command, as a vector.
 +However, if the command has called `read-key-sequence', it returns
 +the last key sequence that has been read.
 +
 +See also `this-command-keys'.  */)
 +  (void)
 +{
 +  return Fvector (this_command_key_count,
 +		  XVECTOR (this_command_keys)->contents);
 +}
 +
 +DEFUN ("this-single-command-keys", Fthis_single_command_keys,
 +       Sthis_single_command_keys, 0, 0, 0,
 +       doc: /* Return the key sequence that invoked this command.
 +More generally, it returns the last key sequence read, either by
 +the command loop or by `read-key-sequence'.
 +Unlike `this-command-keys', this function's value
 +does not include prefix arguments.
 +The value is always a vector.  */)
 +  (void)
 +{
 +  return Fvector (this_command_key_count
 +		  - this_single_command_key_start,
 +		  (XVECTOR (this_command_keys)->contents
 +		   + this_single_command_key_start));
 +}
 +
 +DEFUN ("this-single-command-raw-keys", Fthis_single_command_raw_keys,
 +       Sthis_single_command_raw_keys, 0, 0, 0,
 +       doc: /* Return the raw events that were read for this command.
 +More generally, it returns the last key sequence read, either by
 +the command loop or by `read-key-sequence'.
 +Unlike `this-single-command-keys', this function's value
 +shows the events before all translations (except for input methods).
 +The value is always a vector.  */)
 +  (void)
 +{
 +  return Fvector (raw_keybuf_count, XVECTOR (raw_keybuf)->contents);
 +}
 +
 +DEFUN ("reset-this-command-lengths", Freset_this_command_lengths,
 +       Sreset_this_command_lengths, 0, 0, 0,
 +       doc: /* Make the unread events replace the last command and echo.
 +Used in `universal-argument-other-key'.
 +
 +`universal-argument-other-key' rereads the event just typed.
 +It then gets translated through `function-key-map'.
 +The translated event has to replace the real events,
 +both in the value of (this-command-keys) and in echoing.
 +To achieve this, `universal-argument-other-key' calls
 +`reset-this-command-lengths', which discards the record of reading
 +these events the first time.  */)
 +  (void)
 +{
 +  this_command_key_count = before_command_key_count;
 +  if (this_command_key_count < this_single_command_key_start)
 +    this_single_command_key_start = this_command_key_count;
 +
 +  echo_truncate (before_command_echo_length);
 +
 +  /* Cause whatever we put into unread-command-events
 +     to echo as if it were being freshly read from the keyboard.  */
 +  this_command_key_count_reset = 1;
 +
 +  return Qnil;
 +}
 +
 +DEFUN ("clear-this-command-keys", Fclear_this_command_keys,
 +       Sclear_this_command_keys, 0, 1, 0,
 +       doc: /* Clear out the vector that `this-command-keys' returns.
 +Also clear the record of the last 100 events, unless optional arg
 +KEEP-RECORD is non-nil.  */)
 +  (Lisp_Object keep_record)
 +{
 +  int i;
 +
 +  this_command_key_count = 0;
 +  this_command_key_count_reset = 0;
 +
 +  if (NILP (keep_record))
 +    {
 +      for (i = 0; i < ASIZE (recent_keys); ++i)
 +	ASET (recent_keys, i, Qnil);
 +      total_keys = 0;
 +      recent_keys_index = 0;
 +    }
 +  return Qnil;
 +}
 +
 +DEFUN ("recursion-depth", Frecursion_depth, Srecursion_depth, 0, 0, 0,
 +       doc: /* Return the current depth in recursive edits.  */)
 +  (void)
 +{
 +  Lisp_Object temp;
 +  /* Wrap around reliably on integer overflow.  */
 +  EMACS_INT sum = (command_loop_level & INTMASK) + (minibuf_level & INTMASK);
 +  XSETINT (temp, sum);
 +  return temp;
 +}
 +
 +DEFUN ("open-dribble-file", Fopen_dribble_file, Sopen_dribble_file, 1, 1,
 +       "FOpen dribble file: ",
 +       doc: /* Start writing all keyboard characters to a dribble file called FILE.
 +If FILE is nil, close any open dribble file.
 +The file will be closed when Emacs exits.
 +
 +Be aware that this records ALL characters you type!
 +This may include sensitive information such as passwords.  */)
 +  (Lisp_Object file)
 +{
 +  if (dribble)
 +    {
 +      block_input ();
 +      fclose (dribble);
 +      unblock_input ();
 +      dribble = 0;
 +    }
 +  if (!NILP (file))
 +    {
 +      int fd;
 +      Lisp_Object encfile;
 +
 +      file = Fexpand_file_name (file, Qnil);
 +      encfile = ENCODE_FILE (file);
 +      fd = emacs_open (SSDATA (encfile), O_WRONLY | O_CREAT | O_EXCL, 0600);
 +      if (fd < 0 && errno == EEXIST && unlink (SSDATA (encfile)) == 0)
 +	fd = emacs_open (SSDATA (encfile), O_WRONLY | O_CREAT | O_EXCL, 0600);
 +      dribble = fd < 0 ? 0 : fdopen (fd, "w");
 +      if (dribble == 0)
 +	report_file_error ("Opening dribble", file);
 +    }
 +  return Qnil;
 +}
 +
 +DEFUN ("discard-input", Fdiscard_input, Sdiscard_input, 0, 0, 0,
 +       doc: /* Discard the contents of the terminal input buffer.
 +Also end any kbd macro being defined.  */)
 +  (void)
 +{
 +  if (!NILP (KVAR (current_kboard, defining_kbd_macro)))
 +    {
 +      /* Discard the last command from the macro.  */
 +      Fcancel_kbd_macro_events ();
 +      end_kbd_macro ();
 +    }
 +
 +  Vunread_command_events = Qnil;
 +
 +  discard_tty_input ();
 +
 +  kbd_fetch_ptr =  kbd_store_ptr;
 +  input_pending = 0;
 +
 +  return Qnil;
 +}
 +
 +DEFUN ("suspend-emacs", Fsuspend_emacs, Ssuspend_emacs, 0, 1, "",
 +       doc: /* Stop Emacs and return to superior process.  You can resume later.
 +If `cannot-suspend' is non-nil, or if the system doesn't support job
 +control, run a subshell instead.
 +
 +If optional arg STUFFSTRING is non-nil, its characters are stuffed
 +to be read as terminal input by Emacs's parent, after suspension.
 +
 +Before suspending, run the normal hook `suspend-hook'.
 +After resumption run the normal hook `suspend-resume-hook'.
 +
 +Some operating systems cannot stop the Emacs process and resume it later.
 +On such systems, Emacs starts a subshell instead of suspending.  */)
 +  (Lisp_Object stuffstring)
 +{
 +  ptrdiff_t count = SPECPDL_INDEX ();
 +  int old_height, old_width;
 +  int width, height;
 +  struct gcpro gcpro1;
 +
 +  if (tty_list && tty_list->next)
 +    error ("There are other tty frames open; close them before suspending Emacs");
 +
 +  if (!NILP (stuffstring))
 +    CHECK_STRING (stuffstring);
 +
 +  run_hook (intern ("suspend-hook"));
 +
 +  GCPRO1 (stuffstring);
 +  get_tty_size (fileno (CURTTY ()->input), &old_width, &old_height);
 +  reset_all_sys_modes ();
 +  /* sys_suspend can get an error if it tries to fork a subshell
 +     and the system resources aren't available for that.  */
 +  record_unwind_protect_void (init_all_sys_modes);
 +  stuff_buffered_input (stuffstring);
 +  if (cannot_suspend)
 +    sys_subshell ();
 +  else
 +    sys_suspend ();
 +  unbind_to (count, Qnil);
 +
 +  /* Check if terminal/window size has changed.
 +     Note that this is not useful when we are running directly
 +     with a window system; but suspend should be disabled in that case.  */
 +  get_tty_size (fileno (CURTTY ()->input), &width, &height);
 +  if (width != old_width || height != old_height)
 +    change_frame_size (SELECTED_FRAME (), width,
 +		       height - FRAME_MENU_BAR_LINES (SELECTED_FRAME ()),
 +		       0, 0, 0, 0);
 +
 +  run_hook (intern ("suspend-resume-hook"));
 +
 +  UNGCPRO;
 +  return Qnil;
 +}
 +
 +/* If STUFFSTRING is a string, stuff its contents as pending terminal input.
 +   Then in any case stuff anything Emacs has read ahead and not used.  */
 +
 +void
 +stuff_buffered_input (Lisp_Object stuffstring)
 +{
 +#ifdef SIGTSTP  /* stuff_char is defined if SIGTSTP.  */
 +  register unsigned char *p;
 +
 +  if (STRINGP (stuffstring))
 +    {
 +      register ptrdiff_t count;
 +
 +      p = SDATA (stuffstring);
 +      count = SBYTES (stuffstring);
 +      while (count-- > 0)
 +	stuff_char (*p++);
 +      stuff_char ('\n');
 +    }
 +
 +  /* Anything we have read ahead, put back for the shell to read.  */
 +  /* ?? What should this do when we have multiple keyboards??
 +     Should we ignore anything that was typed in at the "wrong" kboard?
 +
 +     rms: we should stuff everything back into the kboard
 +     it came from.  */
 +  for (; kbd_fetch_ptr != kbd_store_ptr; kbd_fetch_ptr++)
 +    {
 +
 +      if (kbd_fetch_ptr == kbd_buffer + KBD_BUFFER_SIZE)
 +	kbd_fetch_ptr = kbd_buffer;
 +      if (kbd_fetch_ptr->kind == ASCII_KEYSTROKE_EVENT)
 +	stuff_char (kbd_fetch_ptr->code);
 +
 +      clear_event (kbd_fetch_ptr);
 +    }
 +
 +  input_pending = 0;
 +#endif /* SIGTSTP */
 +}
 +
 +void
 +set_waiting_for_input (struct timespec *time_to_clear)
 +{
 +  input_available_clear_time = time_to_clear;
 +
 +  /* Tell handle_interrupt to throw back to read_char,  */
 +  waiting_for_input = 1;
 +
 +  /* If handle_interrupt was called before and buffered a C-g,
 +     make it run again now, to avoid timing error.  */
 +  if (!NILP (Vquit_flag))
 +    quit_throw_to_read_char (0);
 +}
 +
 +void
 +clear_waiting_for_input (void)
 +{
 +  /* Tell handle_interrupt not to throw back to read_char,  */
 +  waiting_for_input = 0;
 +  input_available_clear_time = 0;
 +}
 +
 +/* The SIGINT handler.
 +
 +   If we have a frame on the controlling tty, we assume that the
 +   SIGINT was generated by C-g, so we call handle_interrupt.
 +   Otherwise, tell QUIT to kill Emacs.  */
 +
 +static void
 +handle_interrupt_signal (int sig)
 +{
 +  /* See if we have an active terminal on our controlling tty.  */
 +  struct terminal *terminal = get_named_terminal ("/dev/tty");
 +  if (!terminal)
 +    {
 +      /* If there are no frames there, let's pretend that we are a
 +         well-behaving UN*X program and quit.  We must not call Lisp
 +         in a signal handler, so tell QUIT to exit when it is
 +         safe.  */
 +      Vquit_flag = Qkill_emacs;
 +    }
 +  else
 +    {
 +      /* Otherwise, the SIGINT was probably generated by C-g.  */
 +
 +      /* Set internal_last_event_frame to the top frame of the
 +         controlling tty, if we have a frame there.  We disable the
 +         interrupt key on secondary ttys, so the SIGINT must have come
 +         from the controlling tty.  */
 +      internal_last_event_frame = terminal->display_info.tty->top_frame;
 +
 +      handle_interrupt (1);
 +    }
 +}
 +
 +static void
 +deliver_interrupt_signal (int sig)
 +{
 +  deliver_process_signal (sig, handle_interrupt_signal);
 +}
 +
 +
 +/* If Emacs is stuck because `inhibit-quit' is true, then keep track
 +   of the number of times C-g has been requested.  If C-g is pressed
 +   enough times, then quit anyway.  See bug#6585.  */
 +static int volatile force_quit_count;
 +
 +/* This routine is called at interrupt level in response to C-g.
 +
 +   It is called from the SIGINT handler or kbd_buffer_store_event.
 +
 +   If `waiting_for_input' is non zero, then unless `echoing' is
 +   nonzero, immediately throw back to read_char.
 +
 +   Otherwise it sets the Lisp variable quit-flag not-nil.  This causes
 +   eval to throw, when it gets a chance.  If quit-flag is already
 +   non-nil, it stops the job right away.  */
 +
 +static void
 +handle_interrupt (bool in_signal_handler)
 +{
 +  char c;
 +
 +  cancel_echoing ();
 +
 +  /* XXX This code needs to be revised for multi-tty support.  */
 +  if (!NILP (Vquit_flag) && get_named_terminal ("/dev/tty"))
 +    {
 +      if (! in_signal_handler)
 +	{
 +	  /* If SIGINT isn't blocked, don't let us be interrupted by
 +	     a SIGINT.  It might be harmful due to non-reentrancy
 +	     in I/O functions.  */
 +	  sigset_t blocked;
 +	  sigemptyset (&blocked);
 +	  sigaddset (&blocked, SIGINT);
 +	  pthread_sigmask (SIG_BLOCK, &blocked, 0);
 +	}
 +
 +      fflush (stdout);
 +      reset_all_sys_modes ();
 +
 +#ifdef SIGTSTP
 +/*
 + * On systems which can suspend the current process and return to the original
 + * shell, this command causes the user to end up back at the shell.
 + * The "Auto-save" and "Abort" questions are not asked until
 + * the user elects to return to emacs, at which point he can save the current
 + * job and either dump core or continue.
 + */
 +      sys_suspend ();
 +#else
 +      /* Perhaps should really fork an inferior shell?
 +	 But that would not provide any way to get back
 +	 to the original shell, ever.  */
 +      printf ("No support for stopping a process on this operating system;\n");
 +      printf ("you can continue or abort.\n");
 +#endif /* not SIGTSTP */
 +#ifdef MSDOS
 +      /* We must remain inside the screen area when the internal terminal
 +	 is used.  Note that [Enter] is not echoed by dos.  */
 +      cursor_to (SELECTED_FRAME (), 0, 0);
 +#endif
 +      /* It doesn't work to autosave while GC is in progress;
 +	 the code used for auto-saving doesn't cope with the mark bit.  */
 +      if (!gc_in_progress)
 +	{
 +	  printf ("Auto-save? (y or n) ");
 +	  fflush (stdout);
 +	  if (((c = getchar ()) & ~040) == 'Y')
 +	    {
 +	      Fdo_auto_save (Qt, Qnil);
 +#ifdef MSDOS
 +	      printf ("\r\nAuto-save done");
 +#else /* not MSDOS */
 +	      printf ("Auto-save done\n");
 +#endif /* not MSDOS */
 +	    }
 +	  while (c != '\n') c = getchar ();
 +	}
 +      else
 +	{
 +	  /* During GC, it must be safe to reenable quitting again.  */
 +	  Vinhibit_quit = Qnil;
 +#ifdef MSDOS
 +	  printf ("\r\n");
 +#endif /* not MSDOS */
 +	  printf ("Garbage collection in progress; cannot auto-save now\r\n");
 +	  printf ("but will instead do a real quit after garbage collection ends\r\n");
 +	  fflush (stdout);
 +	}
 +
 +#ifdef MSDOS
 +      printf ("\r\nAbort?  (y or n) ");
 +#else /* not MSDOS */
 +      printf ("Abort (and dump core)? (y or n) ");
 +#endif /* not MSDOS */
 +      fflush (stdout);
 +      if (((c = getchar ()) & ~040) == 'Y')
 +	emacs_abort ();
 +      while (c != '\n') c = getchar ();
 +#ifdef MSDOS
 +      printf ("\r\nContinuing...\r\n");
 +#else /* not MSDOS */
 +      printf ("Continuing...\n");
 +#endif /* not MSDOS */
 +      fflush (stdout);
 +      init_all_sys_modes ();
 +    }
 +  else
 +    {
 +      /* If executing a function that wants to be interrupted out of
 +	 and the user has not deferred quitting by binding `inhibit-quit'
 +	 then quit right away.  */
 +      if (immediate_quit && NILP (Vinhibit_quit))
 +	{
 +	  struct gl_state_s saved;
 +	  struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 +
 +	  immediate_quit = 0;
 +	  pthread_sigmask (SIG_SETMASK, &empty_mask, 0);
 +	  saved = gl_state;
 +	  GCPRO4 (saved.object, saved.global_code,
 +		  saved.current_syntax_table, saved.old_prop);
 +	  Fsignal (Qquit, Qnil);
 +	  gl_state = saved;
 +	  UNGCPRO;
 +	}
 +      else
 +        { /* Else request quit when it's safe.  */
 +	  int count = NILP (Vquit_flag) ? 1 : force_quit_count + 1;
 +	  force_quit_count = count;
 +	  if (count == 3)
 +            {
 +              immediate_quit = 1;
 +              Vinhibit_quit = Qnil;
 +            }
 +          Vquit_flag = Qt;
 +        }
 +    }
 +
 +  pthread_sigmask (SIG_SETMASK, &empty_mask, 0);
 +
 +/* TODO: The longjmp in this call throws the NS event loop integration off,
 +         and it seems to do fine without this.  Probably some attention
 +	 needs to be paid to the setting of waiting_for_input in
 +         wait_reading_process_output() under HAVE_NS because of the call
 +         to ns_select there (needed because otherwise events aren't picked up
 +         outside of polling since we don't get SIGIO like X and we don't have a
 +         separate event loop thread like W32.  */
 +#ifndef HAVE_NS
 +  if (waiting_for_input && !echoing)
 +    quit_throw_to_read_char (in_signal_handler);
 +#endif
 +}
 +
 +/* Handle a C-g by making read_char return C-g.  */
 +
 +static void
 +quit_throw_to_read_char (bool from_signal)
 +{
 +  /* When not called from a signal handler it is safe to call
 +     Lisp.  */
 +  if (!from_signal && EQ (Vquit_flag, Qkill_emacs))
 +    Fkill_emacs (Qnil);
 +
 +  /* Prevent another signal from doing this before we finish.  */
 +  clear_waiting_for_input ();
 +  input_pending = 0;
 +
 +  Vunread_command_events = Qnil;
 +
 +  if (FRAMEP (internal_last_event_frame)
 +      && !EQ (internal_last_event_frame, selected_frame))
 +    do_switch_frame (make_lispy_switch_frame (internal_last_event_frame),
 +		     0, 0, Qnil);
 +
 +  sys_longjmp (getcjmp, 1);
 +}
 +
 +DEFUN ("set-input-interrupt-mode", Fset_input_interrupt_mode,
 +       Sset_input_interrupt_mode, 1, 1, 0,
 +       doc: /* Set interrupt mode of reading keyboard input.
 +If INTERRUPT is non-nil, Emacs will use input interrupts;
 +otherwise Emacs uses CBREAK mode.
 +
 +See also `current-input-mode'.  */)
 +  (Lisp_Object interrupt)
 +{
 +  bool new_interrupt_input;
 +#ifdef USABLE_SIGIO
 +#ifdef HAVE_X_WINDOWS
 +  if (x_display_list != NULL)
 +    {
 +      /* When using X, don't give the user a real choice,
 +	 because we haven't implemented the mechanisms to support it.  */
 +      new_interrupt_input = 1;
 +    }
 +  else
 +#endif /* HAVE_X_WINDOWS */
 +    new_interrupt_input = !NILP (interrupt);
 +#else /* not USABLE_SIGIO */
 +  new_interrupt_input = 0;
 +#endif /* not USABLE_SIGIO */
 +
 +  if (new_interrupt_input != interrupt_input)
 +    {
 +#ifdef POLL_FOR_INPUT
 +      stop_polling ();
 +#endif
 +#ifndef DOS_NT
 +      /* this causes startup screen to be restored and messes with the mouse */
 +      reset_all_sys_modes ();
 +      interrupt_input = new_interrupt_input;
 +      init_all_sys_modes ();
 +#else
 +      interrupt_input = new_interrupt_input;
 +#endif
 +
 +#ifdef POLL_FOR_INPUT
 +      poll_suppress_count = 1;
 +      start_polling ();
 +#endif
 +    }
 +  return Qnil;
 +}
 +
 +DEFUN ("set-output-flow-control", Fset_output_flow_control, Sset_output_flow_control, 1, 2, 0,
 +       doc: /* Enable or disable ^S/^Q flow control for output to TERMINAL.
 +If FLOW is non-nil, flow control is enabled and you cannot use C-s or
 +C-q in key sequences.
 +
 +This setting only has an effect on tty terminals and only when
 +Emacs reads input in CBREAK mode; see `set-input-interrupt-mode'.
 +
 +See also `current-input-mode'.  */)
 +  (Lisp_Object flow, Lisp_Object terminal)
 +{
 +  struct terminal *t = decode_tty_terminal (terminal);
 +  struct tty_display_info *tty;
 +
 +  if (!t)
 +    return Qnil;
 +  tty = t->display_info.tty;
 +
 +  if (tty->flow_control != !NILP (flow))
 +    {
 +#ifndef DOS_NT
 +      /* This causes startup screen to be restored and messes with the mouse.  */
 +      reset_sys_modes (tty);
 +#endif
 +
 +      tty->flow_control = !NILP (flow);
 +
 +#ifndef DOS_NT
 +      init_sys_modes (tty);
 +#endif
 +    }
 +  return Qnil;
 +}
 +
 +DEFUN ("set-input-meta-mode", Fset_input_meta_mode, Sset_input_meta_mode, 1, 2, 0,
 +       doc: /* Enable or disable 8-bit input on TERMINAL.
 +If META is t, Emacs will accept 8-bit input, and interpret the 8th
 +bit as the Meta modifier.
 +
 +If META is nil, Emacs will ignore the top bit, on the assumption it is
 +parity.
 +
 +Otherwise, Emacs will accept and pass through 8-bit input without
 +specially interpreting the top bit.
 +
 +This setting only has an effect on tty terminal devices.
 +
 +Optional parameter TERMINAL specifies the tty terminal device to use.
 +It may be a terminal object, a frame, or nil for the terminal used by
 +the currently selected frame.
 +
 +See also `current-input-mode'.  */)
 +  (Lisp_Object meta, Lisp_Object terminal)
 +{
 +  struct terminal *t = decode_tty_terminal (terminal);
 +  struct tty_display_info *tty;
 +  int new_meta;
 +
 +  if (!t)
 +    return Qnil;
 +  tty = t->display_info.tty;
 +
 +  if (NILP (meta))
 +    new_meta = 0;
 +  else if (EQ (meta, Qt))
 +    new_meta = 1;
 +  else
 +    new_meta = 2;
 +
 +  if (tty->meta_key != new_meta)
 +    {
 +#ifndef DOS_NT
 +      /* this causes startup screen to be restored and messes with the mouse */
 +      reset_sys_modes (tty);
 +#endif
 +
 +      tty->meta_key = new_meta;
 +
 +#ifndef DOS_NT
 +      init_sys_modes (tty);
 +#endif
 +    }
 +  return Qnil;
 +}
 +
 +DEFUN ("set-quit-char", Fset_quit_char, Sset_quit_char, 1, 1, 0,
 +       doc: /* Specify character used for quitting.
 +QUIT must be an ASCII character.
 +
 +This function only has an effect on the controlling tty of the Emacs
 +process.
 +
 +See also `current-input-mode'.  */)
 +  (Lisp_Object quit)
 +{
 +  struct terminal *t = get_named_terminal ("/dev/tty");
 +  struct tty_display_info *tty;
 +
 +  if (!t)
 +    return Qnil;
 +  tty = t->display_info.tty;
 +
 +  if (NILP (quit) || !INTEGERP (quit) || XINT (quit) < 0 || XINT (quit) > 0400)
 +    error ("QUIT must be an ASCII character");
 +
 +#ifndef DOS_NT
 +  /* this causes startup screen to be restored and messes with the mouse */
 +  reset_sys_modes (tty);
 +#endif
 +
 +  /* Don't let this value be out of range.  */
 +  quit_char = XINT (quit) & (tty->meta_key == 0 ? 0177 : 0377);
 +
 +#ifndef DOS_NT
 +  init_sys_modes (tty);
 +#endif
 +
 +  return Qnil;
 +}
 +
 +DEFUN ("set-input-mode", Fset_input_mode, Sset_input_mode, 3, 4, 0,
 +       doc: /* Set mode of reading keyboard input.
 +First arg INTERRUPT non-nil means use input interrupts;
 + nil means use CBREAK mode.
 +Second arg FLOW non-nil means use ^S/^Q flow control for output to terminal
 + (no effect except in CBREAK mode).
 +Third arg META t means accept 8-bit input (for a Meta key).
 + META nil means ignore the top bit, on the assumption it is parity.
 + Otherwise, accept 8-bit input and don't use the top bit for Meta.
 +Optional fourth arg QUIT if non-nil specifies character to use for quitting.
 +See also `current-input-mode'.  */)
 +  (Lisp_Object interrupt, Lisp_Object flow, Lisp_Object meta, Lisp_Object quit)
 +{
 +  Fset_input_interrupt_mode (interrupt);
 +  Fset_output_flow_control (flow, Qnil);
 +  Fset_input_meta_mode (meta, Qnil);
 +  if (!NILP (quit))
 +    Fset_quit_char (quit);
 +  return Qnil;
 +}
 +
 +DEFUN ("current-input-mode", Fcurrent_input_mode, Scurrent_input_mode, 0, 0, 0,
 +       doc: /* Return information about the way Emacs currently reads keyboard input.
 +The value is a list of the form (INTERRUPT FLOW META QUIT), where
 +  INTERRUPT is non-nil if Emacs is using interrupt-driven input; if
 +    nil, Emacs is using CBREAK mode.
 +  FLOW is non-nil if Emacs uses ^S/^Q flow control for output to the
 +    terminal; this does not apply if Emacs uses interrupt-driven input.
 +  META is t if accepting 8-bit input with 8th bit as Meta flag.
 +    META nil means ignoring the top bit, on the assumption it is parity.
 +    META is neither t nor nil if accepting 8-bit input and using
 +    all 8 bits as the character code.
 +  QUIT is the character Emacs currently uses to quit.
 +The elements of this list correspond to the arguments of
 +`set-input-mode'.  */)
 +  (void)
 +{
 +  struct frame *sf = XFRAME (selected_frame);
 +
 +  Lisp_Object interrupt = interrupt_input ? Qt : Qnil;
 +  Lisp_Object flow, meta;
 +  if (FRAME_TERMCAP_P (sf) || FRAME_MSDOS_P (sf))
 +    {
 +      flow = FRAME_TTY (sf)->flow_control ? Qt : Qnil;
 +      meta = (FRAME_TTY (sf)->meta_key == 2
 +	      ? make_number (0)
 +	      : (CURTTY ()->meta_key == 1 ? Qt : Qnil));
 +    }
 +  else
 +    {
 +      flow = Qnil;
 +      meta = Qt;
 +    }
 +  Lisp_Object quit = make_number (quit_char);
 +
 +  return list4 (interrupt, flow, meta, quit);
 +}
 +
 +DEFUN ("posn-at-x-y", Fposn_at_x_y, Sposn_at_x_y, 2, 4, 0,
 +       doc: /* Return position information for pixel coordinates X and Y.
 +By default, X and Y are relative to text area of the selected window.
 +Optional third arg FRAME-OR-WINDOW non-nil specifies frame or window.
 +If optional fourth arg WHOLE is non-nil, X is relative to the left
 +edge of the window.
 +
 +The return value is similar to a mouse click position:
 +   (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW)
 +    IMAGE (DX . DY) (WIDTH . HEIGHT))
 +The `posn-' functions access elements of such lists.  */)
 +  (Lisp_Object x, Lisp_Object y, Lisp_Object frame_or_window, Lisp_Object whole)
 +{
 +  CHECK_NATNUM (x);
 +  CHECK_NATNUM (y);
 +
 +  if (NILP (frame_or_window))
 +    frame_or_window = selected_window;
 +
 +  if (WINDOWP (frame_or_window))
 +    {
 +      struct window *w = decode_live_window (frame_or_window);
 +
 +      XSETINT (x, (XINT (x)
 +		   + WINDOW_LEFT_EDGE_X (w)
 +		   + (NILP (whole)
 +		      ? window_box_left_offset (w, TEXT_AREA)
 +		      : 0)));
 +      XSETINT (y, WINDOW_TO_FRAME_PIXEL_Y (w, XINT (y)));
 +      frame_or_window = w->frame;
 +    }
 +
 +  CHECK_LIVE_FRAME (frame_or_window);
 +
 +  return make_lispy_position (XFRAME (frame_or_window), x, y, 0);
 +}
 +
 +DEFUN ("posn-at-point", Fposn_at_point, Sposn_at_point, 0, 2, 0,
 +       doc: /* Return position information for buffer POS in WINDOW.
 +POS defaults to point in WINDOW; WINDOW defaults to the selected window.
 +
 +Return nil if position is not visible in window.  Otherwise,
 +the return value is similar to that returned by `event-start' for
 +a mouse click at the upper left corner of the glyph corresponding
 +to the given buffer position:
 +   (WINDOW AREA-OR-POS (X . Y) TIMESTAMP OBJECT POS (COL . ROW)
 +    IMAGE (DX . DY) (WIDTH . HEIGHT))
 +The `posn-' functions access elements of such lists.  */)
 +  (Lisp_Object pos, Lisp_Object window)
 +{
 +  Lisp_Object tem;
 +
 +  if (NILP (window))
 +    window = selected_window;
 +
 +  tem = Fpos_visible_in_window_p (pos, window, Qt);
 +  if (!NILP (tem))
 +    {
 +      Lisp_Object x = XCAR (tem);
 +      Lisp_Object y = XCAR (XCDR (tem));
 +
 +      /* Point invisible due to hscrolling?  */
 +      if (XINT (x) < 0)
 +	return Qnil;
 +      tem = Fposn_at_x_y (x, y, window, Qnil);
 +    }
 +
 +  return tem;
 +}
 +
 +/* Set up a new kboard object with reasonable initial values.
 +   TYPE is a window system for which this keyboard is used.  */
 +
 +static void
 +init_kboard (KBOARD *kb, Lisp_Object type)
 +{
 +  kset_overriding_terminal_local_map (kb, Qnil);
 +  kset_last_command (kb, Qnil);
 +  kset_real_last_command (kb, Qnil);
 +  kset_keyboard_translate_table (kb, Qnil);
 +  kset_last_repeatable_command (kb, Qnil);
 +  kset_prefix_arg (kb, Qnil);
 +  kset_last_prefix_arg (kb, Qnil);
 +  kset_kbd_queue (kb, Qnil);
 +  kb->kbd_queue_has_data = 0;
 +  kb->immediate_echo = 0;
 +  kset_echo_string (kb, Qnil);
 +  kb->echo_after_prompt = -1;
 +  kb->kbd_macro_buffer = 0;
 +  kb->kbd_macro_bufsize = 0;
 +  kset_defining_kbd_macro (kb, Qnil);
 +  kset_last_kbd_macro (kb, Qnil);
 +  kb->reference_count = 0;
 +  kset_system_key_alist (kb, Qnil);
 +  kset_system_key_syms (kb, Qnil);
 +  kset_window_system (kb, type);
 +  kset_input_decode_map (kb, Fmake_sparse_keymap (Qnil));
 +  kset_local_function_key_map (kb, Fmake_sparse_keymap (Qnil));
 +  Fset_keymap_parent (KVAR (kb, Vlocal_function_key_map), Vfunction_key_map);
 +  kset_default_minibuffer_frame (kb, Qnil);
 +}
 +
 +/* Allocate and basically initialize keyboard
 +   object to use with window system TYPE.  */
 +
 +KBOARD *
 +allocate_kboard (Lisp_Object type)
 +{
 +  KBOARD *kb = xmalloc (sizeof *kb);
 +
 +  init_kboard (kb, type);
 +  kb->next_kboard = all_kboards;
 +  all_kboards = kb;
 +  return kb;
 +}
 +
 +/*
 + * Destroy the contents of a kboard object, but not the object itself.
 + * We use this just before deleting it, or if we're going to initialize
 + * it a second time.
 + */
 +static void
 +wipe_kboard (KBOARD *kb)
 +{
 +  xfree (kb->kbd_macro_buffer);
 +}
 +
 +/* Free KB and memory referenced from it.  */
 +
 +void
 +delete_kboard (KBOARD *kb)
 +{
 +  KBOARD **kbp;
 +
 +  for (kbp = &all_kboards; *kbp != kb; kbp = &(*kbp)->next_kboard)
 +    if (*kbp == NULL)
 +      emacs_abort ();
 +  *kbp = kb->next_kboard;
 +
 +  /* Prevent a dangling reference to KB.  */
 +  if (kb == current_kboard
 +      && FRAMEP (selected_frame)
 +      && FRAME_LIVE_P (XFRAME (selected_frame)))
 +    {
 +      current_kboard = FRAME_KBOARD (XFRAME (selected_frame));
 +      single_kboard = 0;
 +      if (current_kboard == kb)
 +	emacs_abort ();
 +    }
 +
 +  wipe_kboard (kb);
 +  xfree (kb);
 +}
 +
 +void
 +init_keyboard (void)
 +{
 +  /* This is correct before outermost invocation of the editor loop.  */
 +  command_loop_level = -1;
 +  immediate_quit = 0;
 +  quit_char = Ctl ('g');
 +  Vunread_command_events = Qnil;
 +  timer_idleness_start_time = invalid_timespec ();
 +  total_keys = 0;
 +  recent_keys_index = 0;
 +  kbd_fetch_ptr = kbd_buffer;
 +  kbd_store_ptr = kbd_buffer;
 +  do_mouse_tracking = Qnil;
 +  input_pending = 0;
 +  interrupt_input_blocked = 0;
 +  pending_signals = 0;
 +
 +  /* This means that command_loop_1 won't try to select anything the first
 +     time through.  */
 +  internal_last_event_frame = Qnil;
 +  Vlast_event_frame = internal_last_event_frame;
 +
 +  current_kboard = initial_kboard;
 +  /* Re-initialize the keyboard again.  */
 +  wipe_kboard (current_kboard);
 +  /* A value of nil for Vwindow_system normally means a tty, but we also use
 +     it for the initial terminal since there is no window system there.  */
 +  init_kboard (current_kboard, Qnil);
 +
 +  if (!noninteractive)
 +    {
 +      /* Before multi-tty support, these handlers used to be installed
 +         only if the current session was a tty session.  Now an Emacs
 +         session may have multiple display types, so we always handle
 +         SIGINT.  There is special code in handle_interrupt_signal to exit
 +         Emacs on SIGINT when there are no termcap frames on the
 +         controlling terminal.  */
 +      struct sigaction action;
 +      emacs_sigaction_init (&action, deliver_interrupt_signal);
 +      sigaction (SIGINT, &action, 0);
 +#ifndef DOS_NT
 +      /* For systems with SysV TERMIO, C-g is set up for both SIGINT and
 +	 SIGQUIT and we can't tell which one it will give us.  */
 +      sigaction (SIGQUIT, &action, 0);
 +#endif /* not DOS_NT */
 +    }
 +#ifdef USABLE_SIGIO
 +  if (!noninteractive)
 +    {
 +      struct sigaction action;
 +      emacs_sigaction_init (&action, deliver_input_available_signal);
 +      sigaction (SIGIO, &action, 0);
 +    }
 +#endif
 +
 +/* Use interrupt input by default, if it works and noninterrupt input
 +   has deficiencies.  */
 +
 +#ifdef INTERRUPT_INPUT
 +  interrupt_input = 1;
 +#else
 +  interrupt_input = 0;
 +#endif
 +
 +  pthread_sigmask (SIG_SETMASK, &empty_mask, 0);
 +  dribble = 0;
 +
 +  if (keyboard_init_hook)
 +    (*keyboard_init_hook) ();
 +
 +#ifdef POLL_FOR_INPUT
 +  poll_timer = NULL;
 +  poll_suppress_count = 1;
 +  start_polling ();
 +#endif
 +}
 +
 +/* This type's only use is in syms_of_keyboard, to put properties on the
 +   event header symbols.  */
 +struct event_head
 +{
 +  short var;
 +  short kind;
 +};
 +
 +static const struct event_head head_table[] = {
 +  {SYMBOL_INDEX (Qmouse_movement),      SYMBOL_INDEX (Qmouse_movement)},
 +  {SYMBOL_INDEX (Qscroll_bar_movement), SYMBOL_INDEX (Qmouse_movement)},
 +
 +  /* Some of the event heads.  */
 +  {SYMBOL_INDEX (Qswitch_frame),        SYMBOL_INDEX (Qswitch_frame)},
 +
 +  {SYMBOL_INDEX (Qfocus_in),            SYMBOL_INDEX (Qfocus_in)},
 +  {SYMBOL_INDEX (Qfocus_out),           SYMBOL_INDEX (Qfocus_out)},
 +  {SYMBOL_INDEX (Qdelete_frame),        SYMBOL_INDEX (Qdelete_frame)},
 +  {SYMBOL_INDEX (Qiconify_frame),       SYMBOL_INDEX (Qiconify_frame)},
 +  {SYMBOL_INDEX (Qmake_frame_visible),  SYMBOL_INDEX (Qmake_frame_visible)},
 +  /* `select-window' should be handled just like `switch-frame'
 +     in read_key_sequence.  */
 +  {SYMBOL_INDEX (Qselect_window),       SYMBOL_INDEX (Qswitch_frame)}
 +};
 +
 +void
 +syms_of_keyboard (void)
 +{
 +  pending_funcalls = Qnil;
 +  staticpro (&pending_funcalls);
 +
 +  Vlispy_mouse_stem = build_pure_c_string ("mouse");
 +  staticpro (&Vlispy_mouse_stem);
 +
 +  regular_top_level_message = build_pure_c_string ("Back to top level");
 +#ifdef HAVE_STACK_OVERFLOW_HANDLING
 +  recover_top_level_message
 +    = build_pure_c_string ("Re-entering top level after C stack overflow");
 +#endif
 +  DEFVAR_LISP ("internal--top-level-message", Vinternal__top_level_message,
 +	       doc: /* Message displayed by `normal-top-level'.  */);
 +  Vinternal__top_level_message = regular_top_level_message;
 +
 +  /* Tool-bars.  */
 +  DEFSYM (QCimage, ":image");
 +  DEFSYM (Qhelp_echo, "help-echo");
 +  DEFSYM (QCrtl, ":rtl");
 +
 +  staticpro (&item_properties);
 +  item_properties = Qnil;
 +
 +  staticpro (&tool_bar_item_properties);
 +  tool_bar_item_properties = Qnil;
 +  staticpro (&tool_bar_items_vector);
 +  tool_bar_items_vector = Qnil;
 +
 +  DEFSYM (Qtimer_event_handler, "timer-event-handler");
 +  DEFSYM (Qdisabled_command_function, "disabled-command-function");
 +  DEFSYM (Qself_insert_command, "self-insert-command");
 +  DEFSYM (Qforward_char, "forward-char");
 +  DEFSYM (Qbackward_char, "backward-char");
 +
 +  /* Non-nil disable property on a command means do not execute it;
 +     call disabled-command-function's value instead.  */
 +  DEFSYM (Qdisabled, "disabled");
 +
 +  DEFSYM (Qundefined, "undefined");
 +
 +  /* Hooks to run before and after each command.  */
 +  DEFSYM (Qpre_command_hook, "pre-command-hook");
 +  DEFSYM (Qpost_command_hook, "post-command-hook");
 +
 +  DEFSYM (Qdeferred_action_function, "deferred-action-function");
 +  DEFSYM (Qdelayed_warnings_hook, "delayed-warnings-hook");
 +  DEFSYM (Qfunction_key, "function-key");
 +
 +  /* The values of Qevent_kind properties.  */
 +  DEFSYM (Qmouse_click, "mouse-click");
 +
 +  DEFSYM (Qdrag_n_drop, "drag-n-drop");
 +  DEFSYM (Qsave_session, "save-session");
 +  DEFSYM (Qconfig_changed_event, "config-changed-event");
 +
 +  /* Menu and tool bar item parts.  */
 +  DEFSYM (Qmenu_enable, "menu-enable");
 +
 +#ifdef HAVE_NTGUI
 +  DEFSYM (Qlanguage_change, "language-change");
 +#endif
 +
 +#ifdef HAVE_DBUS
 +  DEFSYM (Qdbus_event, "dbus-event");
 +#endif
 +
 +#ifdef USE_FILE_NOTIFY
 +  DEFSYM (Qfile_notify, "file-notify");
 +#endif /* USE_FILE_NOTIFY */
 +
 +  /* Menu and tool bar item parts.  */
 +  DEFSYM (QCenable, ":enable");
 +  DEFSYM (QCvisible, ":visible");
 +  DEFSYM (QChelp, ":help");
 +  DEFSYM (QCfilter, ":filter");
 +  DEFSYM (QCbutton, ":button");
 +  DEFSYM (QCkeys, ":keys");
 +  DEFSYM (QCkey_sequence, ":key-sequence");
 +
 +  /* Non-nil disable property on a command means
 +     do not execute it; call disabled-command-function's value instead.  */
 +  DEFSYM (QCtoggle, ":toggle");
 +  DEFSYM (QCradio, ":radio");
 +  DEFSYM (QClabel, ":label");
 +  DEFSYM (QCvert_only, ":vert-only");
 +
 +  /* Symbols to use for parts of windows.  */
 +  DEFSYM (Qvertical_line, "vertical-line");
 +  DEFSYM (Qright_divider, "right-divider");
 +  DEFSYM (Qbottom_divider, "bottom-divider");
 +
 +  DEFSYM (Qmouse_fixup_help_message, "mouse-fixup-help-message");
 +
 +  DEFSYM (Qabove_handle, "above-handle");
 +  DEFSYM (Qhandle, "handle");
 +  DEFSYM (Qbelow_handle, "below-handle");
 +  DEFSYM (Qup, "up");
 +  DEFSYM (Qdown, "down");
 +  DEFSYM (Qtop, "top");
 +  DEFSYM (Qbottom, "bottom");
 +  DEFSYM (Qend_scroll, "end-scroll");
 +  DEFSYM (Qratio, "ratio");
 +  DEFSYM (Qbefore_handle, "before-handle");
 +  DEFSYM (Qhorizontal_handle, "horizontal-handle");
 +  DEFSYM (Qafter_handle, "after-handle");
 +  DEFSYM (Qleft, "left");
 +  DEFSYM (Qright, "right");
 +  DEFSYM (Qleftmost, "leftmost");
 +  DEFSYM (Qrightmost, "rightmost");
 +
 +  /* Properties of event headers.  */
 +  DEFSYM (Qevent_kind, "event-kind");
 +  DEFSYM (Qevent_symbol_elements, "event-symbol-elements");
 +
 +  /* An event header symbol HEAD may have a property named
 +     Qevent_symbol_element_mask, which is of the form (BASE MODIFIERS);
 +     BASE is the base, unmodified version of HEAD, and MODIFIERS is the
 +     mask of modifiers applied to it.  If present, this is used to help
 +     speed up parse_modifiers.  */
 +  DEFSYM (Qevent_symbol_element_mask, "event-symbol-element-mask");
 +
 +  /* An unmodified event header BASE may have a property named
 +     Qmodifier_cache, which is an alist mapping modifier masks onto
 +     modified versions of BASE.  If present, this helps speed up
 +     apply_modifiers.  */
 +  DEFSYM (Qmodifier_cache, "modifier-cache");
 +
 +  DEFSYM (Qrecompute_lucid_menubar, "recompute-lucid-menubar");
 +  DEFSYM (Qactivate_menubar_hook, "activate-menubar-hook");
 +
 +  DEFSYM (Qpolling_period, "polling-period");
 +
 +  DEFSYM (Qgui_set_selection, "gui-set-selection");
 +
 +  /* The primary selection.  */
 +  DEFSYM (QPRIMARY, "PRIMARY");
 +
 +  DEFSYM (Qhandle_switch_frame, "handle-switch-frame");
 +  DEFSYM (Qhandle_select_window, "handle-select-window");
 +
 +  DEFSYM (Qinput_method_function, "input-method-function");
 +  DEFSYM (Qinput_method_exit_on_first_char, "input-method-exit-on-first-char");
 +  DEFSYM (Qinput_method_use_echo_area, "input-method-use-echo-area");
 +
 +  DEFSYM (Qhelp_form_show, "help-form-show");
 +
 +  DEFSYM (Qecho_keystrokes, "echo-keystrokes");
 +
 +  Fset (Qinput_method_exit_on_first_char, Qnil);
 +  Fset (Qinput_method_use_echo_area, Qnil);
 +
 +  /* Symbols to head events.  */
 +  DEFSYM (Qmouse_movement, "mouse-movement");
 +  DEFSYM (Qscroll_bar_movement, "scroll-bar-movement");
 +  DEFSYM (Qswitch_frame, "switch-frame");
 +  DEFSYM (Qfocus_in, "focus-in");
 +  DEFSYM (Qfocus_out, "focus-out");
 +  DEFSYM (Qdelete_frame, "delete-frame");
 +  DEFSYM (Qiconify_frame, "iconify-frame");
 +  DEFSYM (Qmake_frame_visible, "make-frame-visible");
 +  DEFSYM (Qselect_window, "select-window");
 +  {
 +    int i;
 +
 +    for (i = 0; i < ARRAYELTS (head_table); i++)
 +      {
 +	const struct event_head *p = &head_table[i];
 +	Lisp_Object var = builtin_lisp_symbol (p->var);
 +	Lisp_Object kind = builtin_lisp_symbol (p->kind);
 +	Fput (var, Qevent_kind, kind);
 +	Fput (var, Qevent_symbol_elements, list1 (var));
 +      }
 +  }
 +
 +  button_down_location = Fmake_vector (make_number (5), Qnil);
 +  staticpro (&button_down_location);
 +  mouse_syms = Fmake_vector (make_number (5), Qnil);
 +  staticpro (&mouse_syms);
 +  wheel_syms = Fmake_vector (make_number (ARRAYELTS (lispy_wheel_names)),
 +			     Qnil);
 +  staticpro (&wheel_syms);
 +
 +  {
 +    int i;
 +    int len = ARRAYELTS (modifier_names);
 +
 +    modifier_symbols = Fmake_vector (make_number (len), Qnil);
 +    for (i = 0; i < len; i++)
 +      if (modifier_names[i])
 +	ASET (modifier_symbols, i, intern_c_string (modifier_names[i]));
 +    staticpro (&modifier_symbols);
 +  }
 +
 +  recent_keys = Fmake_vector (make_number (NUM_RECENT_KEYS), Qnil);
 +  staticpro (&recent_keys);
 +
 +  this_command_keys = Fmake_vector (make_number (40), Qnil);
 +  staticpro (&this_command_keys);
 +
 +  raw_keybuf = Fmake_vector (make_number (30), Qnil);
 +  staticpro (&raw_keybuf);
 +
 +  DEFSYM (Qcommand_execute, "command-execute");
 +
 +  accent_key_syms = Qnil;
 +  staticpro (&accent_key_syms);
 +
 +  func_key_syms = Qnil;
 +  staticpro (&func_key_syms);
 +
 +  drag_n_drop_syms = Qnil;
 +  staticpro (&drag_n_drop_syms);
 +
 +  unread_switch_frame = Qnil;
 +  staticpro (&unread_switch_frame);
 +
 +  internal_last_event_frame = Qnil;
 +  staticpro (&internal_last_event_frame);
 +
 +  read_key_sequence_cmd = Qnil;
 +  staticpro (&read_key_sequence_cmd);
 +  read_key_sequence_remapped = Qnil;
 +  staticpro (&read_key_sequence_remapped);
 +
 +  menu_bar_one_keymap_changed_items = Qnil;
 +  staticpro (&menu_bar_one_keymap_changed_items);
 +
 +  menu_bar_items_vector = Qnil;
 +  staticpro (&menu_bar_items_vector);
 +
 +  help_form_saved_window_configs = Qnil;
 +  staticpro (&help_form_saved_window_configs);
 +
 +  defsubr (&Scurrent_idle_time);
 +  defsubr (&Sevent_symbol_parse_modifiers);
 +  defsubr (&Sevent_convert_list);
 +  defsubr (&Sread_key_sequence);
 +  defsubr (&Sread_key_sequence_vector);
 +  defsubr (&Srecursive_edit);
 +  defsubr (&Strack_mouse);
 +  defsubr (&Sinput_pending_p);
 +  defsubr (&Srecent_keys);
 +  defsubr (&Sthis_command_keys);
 +  defsubr (&Sthis_command_keys_vector);
 +  defsubr (&Sthis_single_command_keys);
 +  defsubr (&Sthis_single_command_raw_keys);
 +  defsubr (&Sreset_this_command_lengths);
 +  defsubr (&Sclear_this_command_keys);
 +  defsubr (&Ssuspend_emacs);
 +  defsubr (&Sabort_recursive_edit);
 +  defsubr (&Sexit_recursive_edit);
 +  defsubr (&Srecursion_depth);
 +  defsubr (&Scommand_error_default_function);
 +  defsubr (&Stop_level);
 +  defsubr (&Sdiscard_input);
 +  defsubr (&Sopen_dribble_file);
 +  defsubr (&Sset_input_interrupt_mode);
 +  defsubr (&Sset_output_flow_control);
 +  defsubr (&Sset_input_meta_mode);
 +  defsubr (&Sset_quit_char);
 +  defsubr (&Sset_input_mode);
 +  defsubr (&Scurrent_input_mode);
 +  defsubr (&Sposn_at_point);
 +  defsubr (&Sposn_at_x_y);
 +
 +  DEFVAR_LISP ("last-command-event", last_command_event,
 +		     doc: /* Last input event that was part of a command.  */);
 +
 +  DEFVAR_LISP ("last-nonmenu-event", last_nonmenu_event,
 +	       doc: /* Last input event in a command, except for mouse menu events.
 +Mouse menus give back keys that don't look like mouse events;
 +this variable holds the actual mouse event that led to the menu,
 +so that you can determine whether the command was run by mouse or not.  */);
 +
 +  DEFVAR_LISP ("last-input-event", last_input_event,
 +	       doc: /* Last input event.  */);
 +
 +  DEFVAR_LISP ("unread-command-events", Vunread_command_events,
 +	       doc: /* List of events to be read as the command input.
 +These events are processed first, before actual keyboard input.
 +Events read from this list are not normally added to `this-command-keys',
 +as they will already have been added once as they were read for the first time.
 +An element of the form (t . EVENT) forces EVENT to be added to that list.  */);
 +  Vunread_command_events = Qnil;
 +
 +  DEFVAR_LISP ("unread-post-input-method-events", Vunread_post_input_method_events,
 +	       doc: /* List of events to be processed as input by input methods.
 +These events are processed before `unread-command-events'
 +and actual keyboard input, but are not given to `input-method-function'.  */);
 +  Vunread_post_input_method_events = Qnil;
 +
 +  DEFVAR_LISP ("unread-input-method-events", Vunread_input_method_events,
 +	       doc: /* List of events to be processed as input by input methods.
 +These events are processed after `unread-command-events', but
 +before actual keyboard input.
 +If there's an active input method, the events are given to
 +`input-method-function'.  */);
 +  Vunread_input_method_events = Qnil;
 +
 +  DEFVAR_LISP ("meta-prefix-char", meta_prefix_char,
 +	       doc: /* Meta-prefix character code.
 +Meta-foo as command input turns into this character followed by foo.  */);
 +  XSETINT (meta_prefix_char, 033);
 +
 +  DEFVAR_KBOARD ("last-command", Vlast_command,
 +		 doc: /* The last command executed.
 +Normally a symbol with a function definition, but can be whatever was found
 +in the keymap, or whatever the variable `this-command' was set to by that
 +command.
 +
 +The value `mode-exit' is special; it means that the previous command
 +read an event that told it to exit, and it did so and unread that event.
 +In other words, the present command is the event that made the previous
 +command exit.
 +
 +The value `kill-region' is special; it means that the previous command
 +was a kill command.
 +
 +`last-command' has a separate binding for each terminal device.
 +See Info node `(elisp)Multiple Terminals'.  */);
 +
 +  DEFVAR_KBOARD ("real-last-command", Vreal_last_command,
 +		 doc: /* Same as `last-command', but never altered by Lisp code.
 +Taken from the previous value of `real-this-command'.  */);
 +
 +  DEFVAR_KBOARD ("last-repeatable-command", Vlast_repeatable_command,
 +		 doc: /* Last command that may be repeated.
 +The last command executed that was not bound to an input event.
 +This is the command `repeat' will try to repeat.
 +Taken from a previous value of `real-this-command'.  */);
 +
 +  DEFVAR_LISP ("this-command", Vthis_command,
 +	       doc: /* The command now being executed.
 +The command can set this variable; whatever is put here
 +will be in `last-command' during the following command.  */);
 +  Vthis_command = Qnil;
 +
 +  DEFVAR_LISP ("real-this-command", Vreal_this_command,
 +	       doc: /* This is like `this-command', except that commands should never modify it.  */);
 +  Vreal_this_command = Qnil;
 +
 +  DEFVAR_LISP ("this-command-keys-shift-translated",
 +	       Vthis_command_keys_shift_translated,
 +	       doc: /* Non-nil if the key sequence activating this command was shift-translated.
 +Shift-translation occurs when there is no binding for the key sequence
 +as entered, but a binding was found by changing an upper-case letter
 +to lower-case, or a shifted function key to an unshifted one.  */);
 +  Vthis_command_keys_shift_translated = Qnil;
 +
 +  DEFVAR_LISP ("this-original-command", Vthis_original_command,
 +	       doc: /* The command bound to the current key sequence before remapping.
 +It equals `this-command' if the original command was not remapped through
 +any of the active keymaps.  Otherwise, the value of `this-command' is the
 +result of looking up the original command in the active keymaps.  */);
 +  Vthis_original_command = Qnil;
 +
 +  DEFVAR_INT ("auto-save-interval", auto_save_interval,
 +	      doc: /* Number of input events between auto-saves.
 +Zero means disable autosaving due to number of characters typed.  */);
 +  auto_save_interval = 300;
 +
 +  DEFVAR_LISP ("auto-save-timeout", Vauto_save_timeout,
 +	       doc: /* Number of seconds idle time before auto-save.
 +Zero or nil means disable auto-saving due to idleness.
 +After auto-saving due to this many seconds of idle time,
 +Emacs also does a garbage collection if that seems to be warranted.  */);
 +  XSETFASTINT (Vauto_save_timeout, 30);
 +
 +  DEFVAR_LISP ("echo-keystrokes", Vecho_keystrokes,
 +	       doc: /* Nonzero means echo unfinished commands after this many seconds of pause.
 +The value may be integer or floating point.
 +If the value is zero, don't echo at all.  */);
 +  Vecho_keystrokes = make_number (1);
 +
 +  DEFVAR_INT ("polling-period", polling_period,
 +	      doc: /* Interval between polling for input during Lisp execution.
 +The reason for polling is to make C-g work to stop a running program.
 +Polling is needed only when using X windows and SIGIO does not work.
 +Polling is automatically disabled in all other cases.  */);
 +  polling_period = 2;
 +
 +  DEFVAR_LISP ("double-click-time", Vdouble_click_time,
 +	       doc: /* Maximum time between mouse clicks to make a double-click.
 +Measured in milliseconds.  The value nil means disable double-click
 +recognition; t means double-clicks have no time limit and are detected
 +by position only.  */);
 +  Vdouble_click_time = make_number (500);
 +
 +  DEFVAR_INT ("double-click-fuzz", double_click_fuzz,
 +	      doc: /* Maximum mouse movement between clicks to make a double-click.
 +On window-system frames, value is the number of pixels the mouse may have
 +moved horizontally or vertically between two clicks to make a double-click.
 +On non window-system frames, value is interpreted in units of 1/8 characters
 +instead of pixels.
 +
 +This variable is also the threshold for motion of the mouse
 +to count as a drag.  */);
 +  double_click_fuzz = 3;
 +
 +  DEFVAR_INT ("num-input-keys", num_input_keys,
 +	      doc: /* Number of complete key sequences read as input so far.
 +This includes key sequences read from keyboard macros.
 +The number is effectively the number of interactive command invocations.  */);
 +  num_input_keys = 0;
 +
 +  DEFVAR_INT ("num-nonmacro-input-events", num_nonmacro_input_events,
 +	      doc: /* Number of input events read from the keyboard so far.
 +This does not include events generated by keyboard macros.  */);
 +  num_nonmacro_input_events = 0;
 +
 +  DEFVAR_LISP ("last-event-frame", Vlast_event_frame,
 +	       doc: /* The frame in which the most recently read event occurred.
 +If the last event came from a keyboard macro, this is set to `macro'.  */);
 +  Vlast_event_frame = Qnil;
 +
 +  /* This variable is set up in sysdep.c.  */
 +  DEFVAR_LISP ("tty-erase-char", Vtty_erase_char,
 +	       doc: /* The ERASE character as set by the user with stty.  */);
 +
 +  DEFVAR_LISP ("help-char", Vhelp_char,
 +	       doc: /* Character to recognize as meaning Help.
 +When it is read, do `(eval help-form)', and display result if it's a string.
 +If the value of `help-form' is nil, this char can be read normally.  */);
 +  XSETINT (Vhelp_char, Ctl ('H'));
 +
 +  DEFVAR_LISP ("help-event-list", Vhelp_event_list,
 +	       doc: /* List of input events to recognize as meaning Help.
 +These work just like the value of `help-char' (see that).  */);
 +  Vhelp_event_list = Qnil;
 +
 +  DEFVAR_LISP ("help-form", Vhelp_form,
 +	       doc: /* Form to execute when character `help-char' is read.
 +If the form returns a string, that string is displayed.
 +If `help-form' is nil, the help char is not recognized.  */);
 +  Vhelp_form = Qnil;
 +
 +  DEFVAR_LISP ("prefix-help-command", Vprefix_help_command,
 +	       doc: /* Command to run when `help-char' character follows a prefix key.
 +This command is used only when there is no actual binding
 +for that character after that prefix key.  */);
 +  Vprefix_help_command = Qnil;
 +
 +  DEFVAR_LISP ("top-level", Vtop_level,
 +	       doc: /* Form to evaluate when Emacs starts up.
 +Useful to set before you dump a modified Emacs.  */);
 +  Vtop_level = Qnil;
 +  XSYMBOL (Qtop_level)->declared_special = false;
 +
 +  DEFVAR_KBOARD ("keyboard-translate-table", Vkeyboard_translate_table,
 +                 doc: /* Translate table for local keyboard input, or nil.
 +If non-nil, the value should be a char-table.  Each character read
 +from the keyboard is looked up in this char-table.  If the value found
 +there is non-nil, then it is used instead of the actual input character.
 +
 +The value can also be a string or vector, but this is considered obsolete.
 +If it is a string or vector of length N, character codes N and up are left
 +untranslated.  In a vector, an element which is nil means "no translation".
 +
 +This is applied to the characters supplied to input methods, not their
 +output.  See also `translation-table-for-input'.
 +
 +This variable has a separate binding for each terminal.
 +See Info node `(elisp)Multiple Terminals'.  */);
 +
 +  DEFVAR_BOOL ("cannot-suspend", cannot_suspend,
 +	       doc: /* Non-nil means to always spawn a subshell instead of suspending.
 +\(Even if the operating system has support for stopping a process.\)  */);
 +  cannot_suspend = 0;
 +
 +  DEFVAR_BOOL ("menu-prompting", menu_prompting,
 +	       doc: /* Non-nil means prompt with menus when appropriate.
 +This is done when reading from a keymap that has a prompt string,
 +for elements that have prompt strings.
 +The menu is displayed on the screen
 +if X menus were enabled at configuration
 +time and the previous event was a mouse click prefix key.
 +Otherwise, menu prompting uses the echo area.  */);
 +  menu_prompting = 1;
 +
 +  DEFVAR_LISP ("menu-prompt-more-char", menu_prompt_more_char,
 +	       doc: /* Character to see next line of menu prompt.
 +Type this character while in a menu prompt to rotate around the lines of it.  */);
 +  XSETINT (menu_prompt_more_char, ' ');
 +
 +  DEFVAR_INT ("extra-keyboard-modifiers", extra_keyboard_modifiers,
 +	      doc: /* A mask of additional modifier keys to use with every keyboard character.
 +Emacs applies the modifiers of the character stored here to each keyboard
 +character it reads.  For example, after evaluating the expression
 +    (setq extra-keyboard-modifiers ?\\C-x)
 +all input characters will have the control modifier applied to them.
 +
 +Note that the character ?\\C-@, equivalent to the integer zero, does
 +not count as a control character; rather, it counts as a character
 +with no modifiers; thus, setting `extra-keyboard-modifiers' to zero
 +cancels any modification.  */);
 +  extra_keyboard_modifiers = 0;
 +
 +  DEFSYM (Qdeactivate_mark, "deactivate-mark");
 +  DEFVAR_LISP ("deactivate-mark", Vdeactivate_mark,
 +	       doc: /* If an editing command sets this to t, deactivate the mark afterward.
 +The command loop sets this to nil before each command,
 +and tests the value when the command returns.
 +Buffer modification stores t in this variable.  */);
 +  Vdeactivate_mark = Qnil;
 +  Fmake_variable_buffer_local (Qdeactivate_mark);
 +
 +  DEFVAR_LISP ("pre-command-hook", Vpre_command_hook,
 +	       doc: /* Normal hook run before each command is executed.
 +If an unhandled error happens in running this hook,
 +the function in which the error occurred is unconditionally removed, since
 +otherwise the error might happen repeatedly and make Emacs nonfunctional.  */);
 +  Vpre_command_hook = Qnil;
 +
 +  DEFVAR_LISP ("post-command-hook", Vpost_command_hook,
 +	       doc: /* Normal hook run after each command is executed.
 +If an unhandled error happens in running this hook,
 +the function in which the error occurred is unconditionally removed, since
 +otherwise the error might happen repeatedly and make Emacs nonfunctional.  */);
 +  Vpost_command_hook = Qnil;
 +
 +#if 0
 +  DEFVAR_LISP ("echo-area-clear-hook", ...,
 +	       doc: /* Normal hook run when clearing the echo area.  */);
 +#endif
 +  DEFSYM (Qecho_area_clear_hook, "echo-area-clear-hook");
 +  Fset (Qecho_area_clear_hook, Qnil);
 +
 +  DEFVAR_LISP ("lucid-menu-bar-dirty-flag", Vlucid_menu_bar_dirty_flag,
 +	       doc: /* Non-nil means menu bar, specified Lucid style, needs to be recomputed.  */);
 +  Vlucid_menu_bar_dirty_flag = Qnil;
 +
 +  DEFVAR_LISP ("menu-bar-final-items", Vmenu_bar_final_items,
 +	       doc: /* List of menu bar items to move to the end of the menu bar.
 +The elements of the list are event types that may have menu bar bindings.  */);
 +  Vmenu_bar_final_items = Qnil;
 +
 +  DEFVAR_LISP ("tool-bar-separator-image-expression", Vtool_bar_separator_image_expression,
 +    doc: /* Expression evaluating to the image spec for a tool-bar separator.
 +This is used internally by graphical displays that do not render
 +tool-bar separators natively.  Otherwise it is unused (e.g. on GTK).  */);
 +  Vtool_bar_separator_image_expression = Qnil;
 +
 +  DEFVAR_KBOARD ("overriding-terminal-local-map",
 +		 Voverriding_terminal_local_map,
 +		 doc: /* Per-terminal keymap that takes precedence over all other keymaps.
 +This variable is intended to let commands such as `universal-argument'
 +set up a different keymap for reading the next command.
 +
 +`overriding-terminal-local-map' has a separate binding for each
 +terminal device.  See Info node `(elisp)Multiple Terminals'.  */);
 +
 +  DEFVAR_LISP ("overriding-local-map", Voverriding_local_map,
 +	       doc: /* Keymap that replaces (overrides) local keymaps.
 +If this variable is non-nil, Emacs looks up key bindings in this
 +keymap INSTEAD OF the keymap char property, minor mode maps, and the
 +buffer's local map.  Hence, the only active keymaps would be
 +`overriding-terminal-local-map', this keymap, and `global-keymap', in
 +order of precedence.  */);
 +  Voverriding_local_map = Qnil;
 +
 +  DEFVAR_LISP ("overriding-local-map-menu-flag", Voverriding_local_map_menu_flag,
 +	       doc: /* Non-nil means `overriding-local-map' applies to the menu bar.
 +Otherwise, the menu bar continues to reflect the buffer's local map
 +and the minor mode maps regardless of `overriding-local-map'.  */);
 +  Voverriding_local_map_menu_flag = Qnil;
 +
 +  DEFVAR_LISP ("special-event-map", Vspecial_event_map,
 +	       doc: /* Keymap defining bindings for special events to execute at low level.  */);
 +  Vspecial_event_map = list1 (Qkeymap);
 +
 +  DEFVAR_LISP ("track-mouse", do_mouse_tracking,
 +	       doc: /* Non-nil means generate motion events for mouse motion.  */);
 +
 +  DEFVAR_KBOARD ("system-key-alist", Vsystem_key_alist,
 +		 doc: /* Alist of system-specific X windows key symbols.
 +Each element should have the form (N . SYMBOL) where N is the
 +numeric keysym code (sans the \"system-specific\" bit 1<<28)
 +and SYMBOL is its name.
 +
 +`system-key-alist' has a separate binding for each terminal device.
 +See Info node `(elisp)Multiple Terminals'.  */);
 +
 +  DEFVAR_KBOARD ("local-function-key-map", Vlocal_function_key_map,
 +                 doc: /* Keymap that translates key sequences to key sequences during input.
 +This is used mainly for mapping key sequences into some preferred
 +key events (symbols).
 +
 +The `read-key-sequence' function replaces any subsequence bound by
 +`local-function-key-map' with its binding.  More precisely, when the
 +active keymaps have no binding for the current key sequence but
 +`local-function-key-map' binds a suffix of the sequence to a vector or
 +string, `read-key-sequence' replaces the matching suffix with its
 +binding, and continues with the new sequence.
 +
 +If the binding is a function, it is called with one argument (the prompt)
 +and its return value (a key sequence) is used.
 +
 +The events that come from bindings in `local-function-key-map' are not
 +themselves looked up in `local-function-key-map'.
 +
 +For example, suppose `local-function-key-map' binds `ESC O P' to [f1].
 +Typing `ESC O P' to `read-key-sequence' would return [f1].  Typing
 +`C-x ESC O P' would return [?\\C-x f1].  If [f1] were a prefix key,
 +typing `ESC O P x' would return [f1 x].
 +
 +`local-function-key-map' has a separate binding for each terminal
 +device.  See Info node `(elisp)Multiple Terminals'.  If you need to
 +define a binding on all terminals, change `function-key-map'
 +instead.  Initially, `local-function-key-map' is an empty keymap that
 +has `function-key-map' as its parent on all terminal devices.  */);
 +
 +  DEFVAR_KBOARD ("input-decode-map", Vinput_decode_map,
 +		 doc: /* Keymap that decodes input escape sequences.
 +This is used mainly for mapping ASCII function key sequences into
 +real Emacs function key events (symbols).
 +
 +The `read-key-sequence' function replaces any subsequence bound by
 +`input-decode-map' with its binding.  Contrary to `function-key-map',
 +this map applies its rebinding regardless of the presence of an ordinary
 +binding.  So it is more like `key-translation-map' except that it applies
 +before `function-key-map' rather than after.
 +
 +If the binding is a function, it is called with one argument (the prompt)
 +and its return value (a key sequence) is used.
 +
 +The events that come from bindings in `input-decode-map' are not
 +themselves looked up in `input-decode-map'.  */);
 +
 +  DEFVAR_LISP ("function-key-map", Vfunction_key_map,
 +               doc: /* The parent keymap of all `local-function-key-map' instances.
 +Function key definitions that apply to all terminal devices should go
 +here.  If a mapping is defined in both the current
 +`local-function-key-map' binding and this variable, then the local
 +definition will take precedence.  */);
 +  Vfunction_key_map = Fmake_sparse_keymap (Qnil);
 +
 +  DEFVAR_LISP ("key-translation-map", Vkey_translation_map,
 +               doc: /* Keymap of key translations that can override keymaps.
 +This keymap works like `input-decode-map', but comes after `function-key-map'.
 +Another difference is that it is global rather than terminal-local.  */);
 +  Vkey_translation_map = Fmake_sparse_keymap (Qnil);
 +
 +  DEFVAR_LISP ("deferred-action-list", Vdeferred_action_list,
 +	       doc: /* List of deferred actions to be performed at a later time.
 +The precise format isn't relevant here; we just check whether it is nil.  */);
 +  Vdeferred_action_list = Qnil;
 +
 +  DEFVAR_LISP ("deferred-action-function", Vdeferred_action_function,
 +	       doc: /* Function to call to handle deferred actions, after each command.
 +This function is called with no arguments after each command
 +whenever `deferred-action-list' is non-nil.  */);
 +  Vdeferred_action_function = Qnil;
 +
 +  DEFVAR_LISP ("delayed-warnings-list", Vdelayed_warnings_list,
 +               doc: /* List of warnings to be displayed after this command.
 +Each element must be a list (TYPE MESSAGE [LEVEL [BUFFER-NAME]]),
 +as per the args of `display-warning' (which see).
 +If this variable is non-nil, `delayed-warnings-hook' will be run
 +immediately after running `post-command-hook'.  */);
 +  Vdelayed_warnings_list = Qnil;
 +
 +  DEFVAR_LISP ("timer-list", Vtimer_list,
 +	       doc: /* List of active absolute time timers in order of increasing time.  */);
 +  Vtimer_list = Qnil;
 +
 +  DEFVAR_LISP ("timer-idle-list", Vtimer_idle_list,
 +	       doc: /* List of active idle-time timers in order of increasing time.  */);
 +  Vtimer_idle_list = Qnil;
 +
 +  DEFVAR_LISP ("input-method-function", Vinput_method_function,
 +	       doc: /* If non-nil, the function that implements the current input method.
 +It's called with one argument, a printing character that was just read.
 +\(That means a character with code 040...0176.)
 +Typically this function uses `read-event' to read additional events.
 +When it does so, it should first bind `input-method-function' to nil
 +so it will not be called recursively.
 +
 +The function should return a list of zero or more events
 +to be used as input.  If it wants to put back some events
 +to be reconsidered, separately, by the input method,
 +it can add them to the beginning of `unread-command-events'.
 +
 +The input method function can find in `input-method-previous-message'
 +the previous echo area message.
 +
 +The input method function should refer to the variables
 +`input-method-use-echo-area' and `input-method-exit-on-first-char'
 +for guidance on what to do.  */);
 +  Vinput_method_function = Qlist;
 +
 +  DEFVAR_LISP ("input-method-previous-message",
 +	       Vinput_method_previous_message,
 +	       doc: /* When `input-method-function' is called, hold the previous echo area message.
 +This variable exists because `read-event' clears the echo area
 +before running the input method.  It is nil if there was no message.  */);
 +  Vinput_method_previous_message = Qnil;
 +
 +  DEFVAR_LISP ("show-help-function", Vshow_help_function,
 +	       doc: /* If non-nil, the function that implements the display of help.
 +It's called with one argument, the help string to display.  */);
 +  Vshow_help_function = Qnil;
 +
 +  DEFVAR_LISP ("disable-point-adjustment", Vdisable_point_adjustment,
 +	       doc: /* If non-nil, suppress point adjustment after executing a command.
 +
 +After a command is executed, if point is moved into a region that has
 +special properties (e.g. composition, display), we adjust point to
 +the boundary of the region.  But, when a command sets this variable to
 +non-nil, we suppress the point adjustment.
 +
 +This variable is set to nil before reading a command, and is checked
 +just after executing the command.  */);
 +  Vdisable_point_adjustment = Qnil;
 +
 +  DEFVAR_LISP ("global-disable-point-adjustment",
 +	       Vglobal_disable_point_adjustment,
 +	       doc: /* If non-nil, always suppress point adjustment.
 +
 +The default value is nil, in which case, point adjustment are
 +suppressed only after special commands that set
 +`disable-point-adjustment' (which see) to non-nil.  */);
 +  Vglobal_disable_point_adjustment = Qnil;
 +
 +  DEFVAR_LISP ("minibuffer-message-timeout", Vminibuffer_message_timeout,
 +	       doc: /* How long to display an echo-area message when the minibuffer is active.
 +If the value is not a number, such messages don't time out.  */);
 +  Vminibuffer_message_timeout = make_number (2);
 +
 +  DEFVAR_LISP ("throw-on-input", Vthrow_on_input,
 +	       doc: /* If non-nil, any keyboard input throws to this symbol.
 +The value of that variable is passed to `quit-flag' and later causes a
 +peculiar kind of quitting.  */);
 +  Vthrow_on_input = Qnil;
 +
 +  DEFVAR_LISP ("command-error-function", Vcommand_error_function,
 +	       doc: /* Function to output error messages.
 +Called with three arguments:
 +- the error data, a list of the form (SIGNALED-CONDITION . SIGNAL-DATA)
 +  such as what `condition-case' would bind its variable to,
 +- the context (a string which normally goes at the start of the message),
 +- the Lisp function within which the error was signaled.  */);
 +  Vcommand_error_function = intern ("command-error-default-function");
 +
 +  DEFVAR_LISP ("enable-disabled-menus-and-buttons",
 +	       Venable_disabled_menus_and_buttons,
 +	       doc: /* If non-nil, don't ignore events produced by disabled menu items and tool-bar.
 +
 +Help functions bind this to allow help on disabled menu items
 +and tool-bar buttons.  */);
 +  Venable_disabled_menus_and_buttons = Qnil;
 +
 +  DEFVAR_LISP ("select-active-regions",
 +	       Vselect_active_regions,
 +	       doc: /* If non-nil, an active region automatically sets the primary selection.
 +If the value is `only', only temporarily active regions (usually made
 +by mouse-dragging or shift-selection) set the window selection.
 +
 +This takes effect only when Transient Mark mode is enabled.  */);
 +  Vselect_active_regions = Qt;
 +
 +  DEFVAR_LISP ("saved-region-selection",
 +	       Vsaved_region_selection,
 +	       doc: /* Contents of active region prior to buffer modification.
 +If `select-active-regions' is non-nil, Emacs sets this to the
 +text in the region before modifying the buffer.  The next call to
 +the function `deactivate-mark' uses this to set the window selection.  */);
 +  Vsaved_region_selection = Qnil;
 +
 +  DEFVAR_LISP ("selection-inhibit-update-commands",
 +	       Vselection_inhibit_update_commands,
 +	       doc: /* List of commands which should not update the selection.
 +Normally, if `select-active-regions' is non-nil and the mark remains
 +active after a command (i.e. the mark was not deactivated), the Emacs
 +command loop sets the selection to the text in the region.  However,
 +if the command is in this list, the selection is not updated.  */);
 +  Vselection_inhibit_update_commands
 +    = list2 (Qhandle_switch_frame, Qhandle_select_window);
 +
 +  DEFVAR_LISP ("debug-on-event",
 +               Vdebug_on_event,
 +               doc: /* Enter debugger on this event.  When Emacs
 +receives the special event specified by this variable, it will try to
 +break into the debugger as soon as possible instead of processing the
 +event normally through `special-event-map'.
 +
 +Currently, the only supported values for this
 +variable are `sigusr1' and `sigusr2'.  */);
 +  Vdebug_on_event = intern_c_string ("sigusr2");
 +
 +  /* Create the initial keyboard.  Qt means 'unset'.  */
 +  initial_kboard = allocate_kboard (Qt);
 +}
 +
 +void
 +keys_of_keyboard (void)
 +{
 +  initial_define_key (global_map, Ctl ('Z'), "suspend-emacs");
 +  initial_define_key (control_x_map, Ctl ('Z'), "suspend-emacs");
 +  initial_define_key (meta_map, Ctl ('C'), "exit-recursive-edit");
 +  initial_define_key (global_map, Ctl (']'), "abort-recursive-edit");
 +  initial_define_key (meta_map, 'x', "execute-extended-command");
 +
 +  initial_define_lispy_key (Vspecial_event_map, "delete-frame",
 +			    "handle-delete-frame");
 +  initial_define_lispy_key (Vspecial_event_map, "ns-put-working-text",
 +			    "ns-put-working-text");
 +  initial_define_lispy_key (Vspecial_event_map, "ns-unput-working-text",
 +			    "ns-unput-working-text");
 +  /* Here we used to use `ignore-event' which would simple set prefix-arg to
 +     current-prefix-arg, as is done in `handle-switch-frame'.
 +     But `handle-switch-frame is not run from the special-map.
 +     Commands from that map are run in a special way that automatically
 +     preserves the prefix-arg.  Restoring the prefix arg here is not just
 +     redundant but harmful:
 +     - C-u C-x v =
 +     - current-prefix-arg is set to non-nil, prefix-arg is set to nil.
 +     - after the first prompt, the exit-minibuffer-hook is run which may
 +       iconify a frame and thus push a `iconify-frame' event.
 +     - after running exit-minibuffer-hook, current-prefix-arg is
 +       restored to the non-nil value it had before the prompt.
 +     - we enter the second prompt.
 +       current-prefix-arg is non-nil, prefix-arg is nil.
 +     - before running the first real event, we run the special iconify-frame
 +       event, but we pass the `special' arg to command-execute so
 +       current-prefix-arg and prefix-arg are left untouched.
 +     - here we foolishly copy the non-nil current-prefix-arg to prefix-arg.
 +     - the next key event will have a spuriously non-nil current-prefix-arg.  */
 +  initial_define_lispy_key (Vspecial_event_map, "iconify-frame",
 +			    "ignore");
 +  initial_define_lispy_key (Vspecial_event_map, "make-frame-visible",
 +			    "ignore");
 +  /* Handling it at such a low-level causes read_key_sequence to get
 +   * confused because it doesn't realize that the current_buffer was
 +   * changed by read_char.
 +   *
 +   * initial_define_lispy_key (Vspecial_event_map, "select-window",
 +   * 			    "handle-select-window"); */
 +  initial_define_lispy_key (Vspecial_event_map, "save-session",
 +			    "handle-save-session");
 +
 +#ifdef HAVE_DBUS
 +  /* Define a special event which is raised for dbus callback
 +     functions.  */
 +  initial_define_lispy_key (Vspecial_event_map, "dbus-event",
 +			    "dbus-handle-event");
 +#endif
 +
 +#ifdef USE_FILE_NOTIFY
 +  /* Define a special event which is raised for notification callback
 +     functions.  */
 +  initial_define_lispy_key (Vspecial_event_map, "file-notify",
 +                            "file-notify-handle-event");
 +#endif /* USE_FILE_NOTIFY */
 +
 +  initial_define_lispy_key (Vspecial_event_map, "config-changed-event",
 +			    "ignore");
 +#if defined (WINDOWSNT)
 +  initial_define_lispy_key (Vspecial_event_map, "language-change",
 +			    "ignore");
 +#endif
 +  initial_define_lispy_key (Vspecial_event_map, "focus-in",
 +			    "handle-focus-in");
 +  initial_define_lispy_key (Vspecial_event_map, "focus-out",
 +			    "handle-focus-out");
 +}
 +
 +/* Mark the pointers in the kboard objects.
 +   Called by Fgarbage_collect.  */
 +void
 +mark_kboards (void)
 +{
 +  KBOARD *kb;
 +  Lisp_Object *p;
 +  for (kb = all_kboards; kb; kb = kb->next_kboard)
 +    {
 +      if (kb->kbd_macro_buffer)
 +	for (p = kb->kbd_macro_buffer; p < kb->kbd_macro_ptr; p++)
 +	  mark_object (*p);
 +      mark_object (KVAR (kb, Voverriding_terminal_local_map));
 +      mark_object (KVAR (kb, Vlast_command));
 +      mark_object (KVAR (kb, Vreal_last_command));
 +      mark_object (KVAR (kb, Vkeyboard_translate_table));
 +      mark_object (KVAR (kb, Vlast_repeatable_command));
 +      mark_object (KVAR (kb, Vprefix_arg));
 +      mark_object (KVAR (kb, Vlast_prefix_arg));
 +      mark_object (KVAR (kb, kbd_queue));
 +      mark_object (KVAR (kb, defining_kbd_macro));
 +      mark_object (KVAR (kb, Vlast_kbd_macro));
 +      mark_object (KVAR (kb, Vsystem_key_alist));
 +      mark_object (KVAR (kb, system_key_syms));
 +      mark_object (KVAR (kb, Vwindow_system));
 +      mark_object (KVAR (kb, Vinput_decode_map));
 +      mark_object (KVAR (kb, Vlocal_function_key_map));
 +      mark_object (KVAR (kb, Vdefault_minibuffer_frame));
 +      mark_object (KVAR (kb, echo_string));
 +    }
 +  {
 +    struct input_event *event;
 +    for (event = kbd_fetch_ptr; event != kbd_store_ptr; event++)
 +      {
 +	if (event == kbd_buffer + KBD_BUFFER_SIZE)
 +	  event = kbd_buffer;
 +	/* These two special event types has no Lisp_Objects to mark.  */
 +	if (event->kind != SELECTION_REQUEST_EVENT
 +	    && event->kind != SELECTION_CLEAR_EVENT)
 +	  {
 +	    mark_object (event->x);
 +	    mark_object (event->y);
 +	    mark_object (event->frame_or_window);
 +	    mark_object (event->arg);
 +	  }
 +      }
 +  }
 +}
diff --cc test/manual/etags/c-src/emacs/src/lisp.h
index db8722917ea,00000000000..688589624fe
mode 100644,000000..100644
--- a/test/manual/etags/c-src/emacs/src/lisp.h
+++ b/test/manual/etags/c-src/emacs/src/lisp.h
@@@ -1,4817 -1,0 +1,4817 @@@
 +/* Fundamental definitions for GNU Emacs Lisp interpreter.
 +
- Copyright (C) 1985-1987, 1993-1995, 1997-2016 Free Software Foundation,
++Copyright (C) 1985-1987, 1993-1995, 1997-2017 Free Software Foundation,
 +Inc.
 +
 +This file is part of GNU Emacs.
 +
 +GNU Emacs is free software: you can redistribute it and/or modify
 +it under the terms of the GNU General Public License as published by
 +the Free Software Foundation, either version 3 of the License, or (at
 +your option) any later version.
 +
 +GNU Emacs is distributed in the hope that it will be useful,
 +but WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +GNU General Public License for more details.
 +
 +You should have received a copy of the GNU General Public License
 +along with GNU Emacs.  If not, see .  */
 +
 +#ifndef EMACS_LISP_H
 +#define EMACS_LISP_H
 +
 +#include 
 +#include 
 +#include 
 +#include 
 +#include 
 +#include 
 +#include 
 +
 +#include 
 +#include 
 +
 +INLINE_HEADER_BEGIN
 +
 +/* Define a TYPE constant ID as an externally visible name.  Use like this:
 +
 +      DEFINE_GDB_SYMBOL_BEGIN (TYPE, ID)
 +      # define ID (some integer preprocessor expression of type TYPE)
 +      DEFINE_GDB_SYMBOL_END (ID)
 +
 +   This hack is for the benefit of compilers that do not make macro
 +   definitions or enums visible to the debugger.  It's used for symbols
 +   that .gdbinit needs.  */
 +
 +#define DECLARE_GDB_SYM(type, id) type const id EXTERNALLY_VISIBLE
 +#ifdef MAIN_PROGRAM
 +# define DEFINE_GDB_SYMBOL_BEGIN(type, id) DECLARE_GDB_SYM (type, id)
 +# define DEFINE_GDB_SYMBOL_END(id) = id;
 +#else
 +# define DEFINE_GDB_SYMBOL_BEGIN(type, id) extern DECLARE_GDB_SYM (type, id)
 +# define DEFINE_GDB_SYMBOL_END(val) ;
 +#endif
 +
 +/* The ubiquitous max and min macros.  */
 +#undef min
 +#undef max
 +#define max(a, b) ((a) > (b) ? (a) : (b))
 +#define min(a, b) ((a) < (b) ? (a) : (b))
 +
 +/* Number of elements in an array.  */
 +#define ARRAYELTS(arr) (sizeof (arr) / sizeof (arr)[0])
 +
 +/* Number of bits in a Lisp_Object tag.  */
 +DEFINE_GDB_SYMBOL_BEGIN (int, GCTYPEBITS)
 +#define GCTYPEBITS 3
 +DEFINE_GDB_SYMBOL_END (GCTYPEBITS)
 +
 +/* The number of bits needed in an EMACS_INT over and above the number
 +   of bits in a pointer.  This is 0 on systems where:
 +   1.  We can specify multiple-of-8 alignment on static variables.
 +   2.  We know malloc returns a multiple of 8.  */
 +#if (defined alignas \
 +     && (defined GNU_MALLOC || defined DOUG_LEA_MALLOC || defined __GLIBC__ \
 +	 || defined DARWIN_OS || defined __sun || defined __MINGW32__ \
 +	 || defined CYGWIN))
 +# define NONPOINTER_BITS 0
 +#else
 +# define NONPOINTER_BITS GCTYPEBITS
 +#endif
 +
 +/* EMACS_INT - signed integer wide enough to hold an Emacs value
 +   EMACS_INT_MAX - maximum value of EMACS_INT; can be used in #if
 +   pI - printf length modifier for EMACS_INT
 +   EMACS_UINT - unsigned variant of EMACS_INT */
 +#ifndef EMACS_INT_MAX
 +# if INTPTR_MAX <= 0
 +#  error "INTPTR_MAX misconfigured"
 +# elif INTPTR_MAX <= INT_MAX >> NONPOINTER_BITS && !defined WIDE_EMACS_INT
 +typedef int EMACS_INT;
 +typedef unsigned int EMACS_UINT;
 +#  define EMACS_INT_MAX INT_MAX
 +#  define pI ""
 +# elif INTPTR_MAX <= LONG_MAX >> NONPOINTER_BITS && !defined WIDE_EMACS_INT
 +typedef long int EMACS_INT;
 +typedef unsigned long EMACS_UINT;
 +#  define EMACS_INT_MAX LONG_MAX
 +#  define pI "l"
 +/* Check versus LLONG_MAX, not LLONG_MAX >> NONPOINTER_BITS.
 +   In theory this is not safe, but in practice it seems to be OK.  */
 +# elif INTPTR_MAX <= LLONG_MAX
 +typedef long long int EMACS_INT;
 +typedef unsigned long long int EMACS_UINT;
 +#  define EMACS_INT_MAX LLONG_MAX
 +#  define pI "ll"
 +# else
 +#  error "INTPTR_MAX too large"
 +# endif
 +#endif
 +
 +/* Number of bits to put in each character in the internal representation
 +   of bool vectors.  This should not vary across implementations.  */
 +enum {  BOOL_VECTOR_BITS_PER_CHAR =
 +#define BOOL_VECTOR_BITS_PER_CHAR 8
 +        BOOL_VECTOR_BITS_PER_CHAR
 +};
 +
 +/* An unsigned integer type representing a fixed-length bit sequence,
 +   suitable for bool vector words, GC mark bits, etc.  Normally it is size_t
 +   for speed, but it is unsigned char on weird platforms.  */
 +#if BOOL_VECTOR_BITS_PER_CHAR == CHAR_BIT
 +typedef size_t bits_word;
 +# define BITS_WORD_MAX SIZE_MAX
 +enum { BITS_PER_BITS_WORD = CHAR_BIT * sizeof (bits_word) };
 +#else
 +typedef unsigned char bits_word;
 +# define BITS_WORD_MAX ((1u << BOOL_VECTOR_BITS_PER_CHAR) - 1)
 +enum { BITS_PER_BITS_WORD = BOOL_VECTOR_BITS_PER_CHAR };
 +#endif
 +verify (BITS_WORD_MAX >> (BITS_PER_BITS_WORD - 1) == 1);
 +
 +/* Number of bits in some machine integer types.  */
 +enum
 +  {
 +    BITS_PER_CHAR      = CHAR_BIT,
 +    BITS_PER_SHORT     = CHAR_BIT * sizeof (short),
 +    BITS_PER_LONG      = CHAR_BIT * sizeof (long int),
 +    BITS_PER_EMACS_INT = CHAR_BIT * sizeof (EMACS_INT)
 +  };
 +
 +/* printmax_t and uprintmax_t are types for printing large integers.
 +   These are the widest integers that are supported for printing.
 +   pMd etc. are conversions for printing them.
 +   On C99 hosts, there's no problem, as even the widest integers work.
 +   Fall back on EMACS_INT on pre-C99 hosts.  */
 +#ifdef PRIdMAX
 +typedef intmax_t printmax_t;
 +typedef uintmax_t uprintmax_t;
 +# define pMd PRIdMAX
 +# define pMu PRIuMAX
 +#else
 +typedef EMACS_INT printmax_t;
 +typedef EMACS_UINT uprintmax_t;
 +# define pMd pI"d"
 +# define pMu pI"u"
 +#endif
 +
 +/* Use pD to format ptrdiff_t values, which suffice for indexes into
 +   buffers and strings.  Emacs never allocates objects larger than
 +   PTRDIFF_MAX bytes, as they cause problems with pointer subtraction.
 +   In C99, pD can always be "t"; configure it here for the sake of
 +   pre-C99 libraries such as glibc 2.0 and Solaris 8.  */
 +#if PTRDIFF_MAX == INT_MAX
 +# define pD ""
 +#elif PTRDIFF_MAX == LONG_MAX
 +# define pD "l"
 +#elif PTRDIFF_MAX == LLONG_MAX
 +# define pD "ll"
 +#else
 +# define pD "t"
 +#endif
 +
 +/* Extra internal type checking?  */
 +
 +/* Define Emacs versions of 's 'assert (COND)' and 's
 +   'assume (COND)'.  COND should be free of side effects, as it may or
 +   may not be evaluated.
 +
 +   'eassert (COND)' checks COND at runtime if ENABLE_CHECKING is
 +   defined and suppress_checking is false, and does nothing otherwise.
 +   Emacs dies if COND is checked and is false.  The suppress_checking
 +   variable is initialized to 0 in alloc.c.  Set it to 1 using a
 +   debugger to temporarily disable aborting on detected internal
 +   inconsistencies or error conditions.
 +
 +   In some cases, a good compiler may be able to optimize away the
 +   eassert macro even if ENABLE_CHECKING is true, e.g., if XSTRING (x)
 +   uses eassert to test STRINGP (x), but a particular use of XSTRING
 +   is invoked only after testing that STRINGP (x) is true, making the
 +   test redundant.
 +
 +   eassume is like eassert except that it also causes the compiler to
 +   assume that COND is true afterwards, regardless of whether runtime
 +   checking is enabled.  This can improve performance in some cases,
 +   though it can degrade performance in others.  It's often suboptimal
 +   for COND to call external functions or access volatile storage.  */
 +
 +#ifndef ENABLE_CHECKING
 +# define eassert(cond) ((void) (false && (cond))) /* Check COND compiles.  */
 +# define eassume(cond) assume (cond)
 +#else /* ENABLE_CHECKING */
 +
 +extern _Noreturn void die (const char *, const char *, int);
 +
 +extern bool suppress_checking EXTERNALLY_VISIBLE;
 +
 +# define eassert(cond)						\
 +   (suppress_checking || (cond) 				\
 +    ? (void) 0							\
 +    : die (# cond, __FILE__, __LINE__))
 +# define eassume(cond)						\
 +   (suppress_checking						\
 +    ? assume (cond)						\
 +    : (cond)							\
 +    ? (void) 0							\
 +    : die (# cond, __FILE__, __LINE__))
 +#endif /* ENABLE_CHECKING */
 +
 +
 +/* Use the configure flag --enable-check-lisp-object-type to make
 +   Lisp_Object use a struct type instead of the default int.  The flag
 +   causes CHECK_LISP_OBJECT_TYPE to be defined.  */
 +
 +/***** Select the tagging scheme.  *****/
 +/* The following option controls the tagging scheme:
 +   - USE_LSB_TAG means that we can assume the least 3 bits of pointers are
 +     always 0, and we can thus use them to hold tag bits, without
 +     restricting our addressing space.
 +
 +   If ! USE_LSB_TAG, then use the top 3 bits for tagging, thus
 +   restricting our possible address range.
 +
 +   USE_LSB_TAG not only requires the least 3 bits of pointers returned by
 +   malloc to be 0 but also needs to be able to impose a mult-of-8 alignment
 +   on the few static Lisp_Objects used: lispsym, all the defsubr, and
 +   the two special buffers buffer_defaults and buffer_local_symbols.  */
 +
 +enum Lisp_Bits
 +  {
 +    /* 2**GCTYPEBITS.  This must be a macro that expands to a literal
 +       integer constant, for MSVC.  */
 +#define GCALIGNMENT 8
 +
 +    /* Number of bits in a Lisp_Object value, not counting the tag.  */
 +    VALBITS = BITS_PER_EMACS_INT - GCTYPEBITS,
 +
 +    /* Number of bits in a Lisp fixnum tag.  */
 +    INTTYPEBITS = GCTYPEBITS - 1,
 +
 +    /* Number of bits in a Lisp fixnum value, not counting the tag.  */
 +    FIXNUM_BITS = VALBITS + 1
 +  };
 +
 +#if GCALIGNMENT != 1 << GCTYPEBITS
 +# error "GCALIGNMENT and GCTYPEBITS are inconsistent"
 +#endif
 +
 +/* The maximum value that can be stored in a EMACS_INT, assuming all
 +   bits other than the type bits contribute to a nonnegative signed value.
 +   This can be used in #if, e.g., '#if USB_TAG' below expands to an
 +   expression involving VAL_MAX.  */
 +#define VAL_MAX (EMACS_INT_MAX >> (GCTYPEBITS - 1))
 +
 +/* Whether the least-significant bits of an EMACS_INT contain the tag.
 +   On hosts where pointers-as-ints do not exceed VAL_MAX / 2, USE_LSB_TAG is:
 +    a. unnecessary, because the top bits of an EMACS_INT are unused, and
 +    b. slower, because it typically requires extra masking.
 +   So, USE_LSB_TAG is true only on hosts where it might be useful.  */
 +DEFINE_GDB_SYMBOL_BEGIN (bool, USE_LSB_TAG)
 +#define USE_LSB_TAG (VAL_MAX / 2 < INTPTR_MAX)
 +DEFINE_GDB_SYMBOL_END (USE_LSB_TAG)
 +
 +#if !USE_LSB_TAG && !defined WIDE_EMACS_INT
 +# error "USE_LSB_TAG not supported on this platform; please report this." \
 +	"Try 'configure --with-wide-int' to work around the problem."
 +error !;
 +#endif
 +
 +#ifndef alignas
 +# define alignas(alignment) /* empty */
 +# if USE_LSB_TAG
 +#  error "USE_LSB_TAG requires alignas"
 +# endif
 +#endif
 +
 +#ifdef HAVE_STRUCT_ATTRIBUTE_ALIGNED
 +# define GCALIGNED __attribute__ ((aligned (GCALIGNMENT)))
 +#else
 +# define GCALIGNED /* empty */
 +#endif
 +
 +/* Some operations are so commonly executed that they are implemented
 +   as macros, not functions, because otherwise runtime performance would
 +   suffer too much when compiling with GCC without optimization.
 +   There's no need to inline everything, just the operations that
 +   would otherwise cause a serious performance problem.
 +
 +   For each such operation OP, define a macro lisp_h_OP that contains
 +   the operation's implementation.  That way, OP can be implemented
 +   via a macro definition like this:
 +
 +     #define OP(x) lisp_h_OP (x)
 +
 +   and/or via a function definition like this:
 +
 +     LISP_MACRO_DEFUN (OP, Lisp_Object, (Lisp_Object x), (x))
 +
 +   which macro-expands to this:
 +
 +     Lisp_Object (OP) (Lisp_Object x) { return lisp_h_OP (x); }
 +
 +   without worrying about the implementations diverging, since
 +   lisp_h_OP defines the actual implementation.  The lisp_h_OP macros
 +   are intended to be private to this include file, and should not be
 +   used elsewhere.
 +
 +   FIXME: Remove the lisp_h_OP macros, and define just the inline OP
 +   functions, once most developers have access to GCC 4.8 or later and
 +   can use "gcc -Og" to debug.  Maybe in the year 2016.  See
 +   Bug#11935.
 +
 +   Commentary for these macros can be found near their corresponding
 +   functions, below.  */
 +
 +#if CHECK_LISP_OBJECT_TYPE
 +# define lisp_h_XLI(o) ((o).i)
 +# define lisp_h_XIL(i) ((Lisp_Object) { i })
 +#else
 +# define lisp_h_XLI(o) (o)
 +# define lisp_h_XIL(i) (i)
 +#endif
 +#define lisp_h_CHECK_LIST_CONS(x, y) CHECK_TYPE (CONSP (x), Qlistp, y)
 +#define lisp_h_CHECK_NUMBER(x) CHECK_TYPE (INTEGERP (x), Qintegerp, x)
 +#define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x)
 +#define lisp_h_CHECK_TYPE(ok, predicate, x) \
 +   ((ok) ? (void) 0 : (void) wrong_type_argument (predicate, x))
 +#define lisp_h_CONSP(x) (XTYPE (x) == Lisp_Cons)
 +#define lisp_h_EQ(x, y) (XLI (x) == XLI (y))
 +#define lisp_h_FLOATP(x) (XTYPE (x) == Lisp_Float)
 +#define lisp_h_INTEGERP(x) ((XTYPE (x) & (Lisp_Int0 | ~Lisp_Int1)) == Lisp_Int0)
 +#define lisp_h_MARKERP(x) (MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Marker)
 +#define lisp_h_MISCP(x) (XTYPE (x) == Lisp_Misc)
 +#define lisp_h_NILP(x) EQ (x, Qnil)
 +#define lisp_h_SET_SYMBOL_VAL(sym, v) \
 +   (eassert ((sym)->redirect == SYMBOL_PLAINVAL), (sym)->val.value = (v))
 +#define lisp_h_SYMBOL_CONSTANT_P(sym) (XSYMBOL (sym)->constant)
 +#define lisp_h_SYMBOL_VAL(sym) \
 +   (eassert ((sym)->redirect == SYMBOL_PLAINVAL), (sym)->val.value)
 +#define lisp_h_SYMBOLP(x) (XTYPE (x) == Lisp_Symbol)
 +#define lisp_h_VECTORLIKEP(x) (XTYPE (x) == Lisp_Vectorlike)
 +#define lisp_h_XCAR(c) XCONS (c)->car
 +#define lisp_h_XCDR(c) XCONS (c)->u.cdr
 +#define lisp_h_XCONS(a) \
 +   (eassert (CONSP (a)), (struct Lisp_Cons *) XUNTAG (a, Lisp_Cons))
 +#define lisp_h_XHASH(a) XUINT (a)
 +#define lisp_h_XPNTR(a) \
 +   (SYMBOLP (a) ? XSYMBOL (a) : (void *) ((intptr_t) (XLI (a) & VALMASK)))
 +#ifndef GC_CHECK_CONS_LIST
 +# define lisp_h_check_cons_list() ((void) 0)
 +#endif
 +#if USE_LSB_TAG
 +# define lisp_h_make_number(n) \
 +    XIL ((EMACS_INT) (((EMACS_UINT) (n) << INTTYPEBITS) + Lisp_Int0))
 +# define lisp_h_XFASTINT(a) XINT (a)
 +# define lisp_h_XINT(a) (XLI (a) >> INTTYPEBITS)
 +# define lisp_h_XSYMBOL(a) \
 +    (eassert (SYMBOLP (a)), \
 +     (struct Lisp_Symbol *) ((uintptr_t) XLI (a) - Lisp_Symbol \
 +			     + (char *) lispsym))
 +# define lisp_h_XTYPE(a) ((enum Lisp_Type) (XLI (a) & ~VALMASK))
 +# define lisp_h_XUNTAG(a, type) ((void *) (intptr_t) (XLI (a) - (type)))
 +#endif
 +
 +/* When compiling via gcc -O0, define the key operations as macros, as
 +   Emacs is too slow otherwise.  To disable this optimization, compile
 +   with -DINLINING=false.  */
 +#if (defined __NO_INLINE__ \
 +     && ! defined __OPTIMIZE__ && ! defined __OPTIMIZE_SIZE__ \
 +     && ! (defined INLINING && ! INLINING))
 +# define XLI(o) lisp_h_XLI (o)
 +# define XIL(i) lisp_h_XIL (i)
 +# define CHECK_LIST_CONS(x, y) lisp_h_CHECK_LIST_CONS (x, y)
 +# define CHECK_NUMBER(x) lisp_h_CHECK_NUMBER (x)
 +# define CHECK_SYMBOL(x) lisp_h_CHECK_SYMBOL (x)
 +# define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x)
 +# define CONSP(x) lisp_h_CONSP (x)
 +# define EQ(x, y) lisp_h_EQ (x, y)
 +# define FLOATP(x) lisp_h_FLOATP (x)
 +# define INTEGERP(x) lisp_h_INTEGERP (x)
 +# define MARKERP(x) lisp_h_MARKERP (x)
 +# define MISCP(x) lisp_h_MISCP (x)
 +# define NILP(x) lisp_h_NILP (x)
 +# define SET_SYMBOL_VAL(sym, v) lisp_h_SET_SYMBOL_VAL (sym, v)
 +# define SYMBOL_CONSTANT_P(sym) lisp_h_SYMBOL_CONSTANT_P (sym)
 +# define SYMBOL_VAL(sym) lisp_h_SYMBOL_VAL (sym)
 +# define SYMBOLP(x) lisp_h_SYMBOLP (x)
 +# define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x)
 +# define XCAR(c) lisp_h_XCAR (c)
 +# define XCDR(c) lisp_h_XCDR (c)
 +# define XCONS(a) lisp_h_XCONS (a)
 +# define XHASH(a) lisp_h_XHASH (a)
 +# define XPNTR(a) lisp_h_XPNTR (a)
 +# ifndef GC_CHECK_CONS_LIST
 +#  define check_cons_list() lisp_h_check_cons_list ()
 +# endif
 +# if USE_LSB_TAG
 +#  define make_number(n) lisp_h_make_number (n)
 +#  define XFASTINT(a) lisp_h_XFASTINT (a)
 +#  define XINT(a) lisp_h_XINT (a)
 +#  define XSYMBOL(a) lisp_h_XSYMBOL (a)
 +#  define XTYPE(a) lisp_h_XTYPE (a)
 +#  define XUNTAG(a, type) lisp_h_XUNTAG (a, type)
 +# endif
 +#endif
 +
 +/* Define NAME as a lisp.h inline function that returns TYPE and has
 +   arguments declared as ARGDECLS and passed as ARGS.  ARGDECLS and
 +   ARGS should be parenthesized.  Implement the function by calling
 +   lisp_h_NAME ARGS.  */
 +#define LISP_MACRO_DEFUN(name, type, argdecls, args) \
 +  INLINE type (name) argdecls { return lisp_h_##name args; }
 +
 +/* like LISP_MACRO_DEFUN, except NAME returns void.  */
 +#define LISP_MACRO_DEFUN_VOID(name, argdecls, args) \
 +  INLINE void (name) argdecls { lisp_h_##name args; }
 +
 +
 +/* Define the fundamental Lisp data structures.  */
 +
 +/* This is the set of Lisp data types.  If you want to define a new
 +   data type, read the comments after Lisp_Fwd_Type definition
 +   below.  */
 +
 +/* Lisp integers use 2 tags, to give them one extra bit, thus
 +   extending their range from, e.g., -2^28..2^28-1 to -2^29..2^29-1.  */
 +#define INTMASK (EMACS_INT_MAX >> (INTTYPEBITS - 1))
 +#define case_Lisp_Int case Lisp_Int0: case Lisp_Int1
 +
 +/* Idea stolen from GDB.  Pedantic GCC complains about enum bitfields,
 +   MSVC doesn't support them, and xlc and Oracle Studio c99 complain
 +   vociferously about them.  */
 +#if (defined __STRICT_ANSI__ || defined _MSC_VER || defined __IBMC__ \
 +     || (defined __SUNPRO_C && __STDC__))
 +#define ENUM_BF(TYPE) unsigned int
 +#else
 +#define ENUM_BF(TYPE) enum TYPE
 +#endif
 +
 +
 +enum Lisp_Type
 +  {
 +    /* Symbol.  XSYMBOL (object) points to a struct Lisp_Symbol.  */
 +    Lisp_Symbol = 0,
 +
 +    /* Miscellaneous.  XMISC (object) points to a union Lisp_Misc,
 +       whose first member indicates the subtype.  */
 +    Lisp_Misc = 1,
 +
 +    /* Integer.  XINT (obj) is the integer value.  */
 +    Lisp_Int0 = 2,
 +    Lisp_Int1 = USE_LSB_TAG ? 6 : 3,
 +
 +    /* String.  XSTRING (object) points to a struct Lisp_String.
 +       The length of the string, and its contents, are stored therein.  */
 +    Lisp_String = 4,
 +
 +    /* Vector of Lisp objects, or something resembling it.
 +       XVECTOR (object) points to a struct Lisp_Vector, which contains
 +       the size and contents.  The size field also contains the type
 +       information, if it's not a real vector object.  */
 +    Lisp_Vectorlike = 5,
 +
 +    /* Cons.  XCONS (object) points to a struct Lisp_Cons.  */
 +    Lisp_Cons = USE_LSB_TAG ? 3 : 6,
 +
 +    Lisp_Float = 7
 +  };
 +
 +/* This is the set of data types that share a common structure.
 +   The first member of the structure is a type code from this set.
 +   The enum values are arbitrary, but we'll use large numbers to make it
 +   more likely that we'll spot the error if a random word in memory is
 +   mistakenly interpreted as a Lisp_Misc.  */
 +enum Lisp_Misc_Type
 +  {
 +    Lisp_Misc_Free = 0x5eab,
 +    Lisp_Misc_Marker,
 +    Lisp_Misc_Overlay,
 +    Lisp_Misc_Save_Value,
 +    Lisp_Misc_Finalizer,
 +    /* Currently floats are not a misc type,
 +       but let's define this in case we want to change that.  */
 +    Lisp_Misc_Float,
 +    /* This is not a type code.  It is for range checking.  */
 +    Lisp_Misc_Limit
 +  };
 +
 +/* These are the types of forwarding objects used in the value slot
 +   of symbols for special built-in variables whose value is stored in
 +   C variables.  */
 +enum Lisp_Fwd_Type
 +  {
 +    Lisp_Fwd_Int,		/* Fwd to a C `int' variable.  */
 +    Lisp_Fwd_Bool,		/* Fwd to a C boolean var.  */
 +    Lisp_Fwd_Obj,		/* Fwd to a C Lisp_Object variable.  */
 +    Lisp_Fwd_Buffer_Obj,	/* Fwd to a Lisp_Object field of buffers.  */
 +    Lisp_Fwd_Kboard_Obj		/* Fwd to a Lisp_Object field of kboards.  */
 +  };
 +
 +/* If you want to define a new Lisp data type, here are some
 +   instructions.  See the thread at
 +   http://lists.gnu.org/archive/html/emacs-devel/2012-10/msg00561.html
 +   for more info.
 +
 +   First, there are already a couple of Lisp types that can be used if
 +   your new type does not need to be exposed to Lisp programs nor
 +   displayed to users.  These are Lisp_Save_Value, a Lisp_Misc
 +   subtype; and PVEC_OTHER, a kind of vectorlike object.  The former
 +   is suitable for temporarily stashing away pointers and integers in
 +   a Lisp object.  The latter is useful for vector-like Lisp objects
 +   that need to be used as part of other objects, but which are never
 +   shown to users or Lisp code (search for PVEC_OTHER in xterm.c for
 +   an example).
 +
 +   These two types don't look pretty when printed, so they are
 +   unsuitable for Lisp objects that can be exposed to users.
 +
 +   To define a new data type, add one more Lisp_Misc subtype or one
 +   more pseudovector subtype.  Pseudovectors are more suitable for
 +   objects with several slots that need to support fast random access,
 +   while Lisp_Misc types are for everything else.  A pseudovector object
 +   provides one or more slots for Lisp objects, followed by struct
 +   members that are accessible only from C.  A Lisp_Misc object is a
 +   wrapper for a C struct that can contain anything you like.
 +
 +   Explicit freeing is discouraged for Lisp objects in general.  But if
 +   you really need to exploit this, use Lisp_Misc (check free_misc in
 +   alloc.c to see why).  There is no way to free a vectorlike object.
 +
 +   To add a new pseudovector type, extend the pvec_type enumeration;
 +   to add a new Lisp_Misc, extend the Lisp_Misc_Type enumeration.
 +
 +   For a Lisp_Misc, you will also need to add your entry to union
 +   Lisp_Misc (but make sure the first word has the same structure as
 +   the others, starting with a 16-bit member of the Lisp_Misc_Type
 +   enumeration and a 1-bit GC markbit) and make sure the overall size
 +   of the union is not increased by your addition.
 +
 +   For a new pseudovector, it's highly desirable to limit the size
 +   of your data type by VBLOCK_BYTES_MAX bytes (defined in alloc.c).
 +   Otherwise you will need to change sweep_vectors (also in alloc.c).
 +
 +   Then you will need to add switch branches in print.c (in
 +   print_object, to print your object, and possibly also in
 +   print_preprocess) and to alloc.c, to mark your object (in
 +   mark_object) and to free it (in gc_sweep).  The latter is also the
 +   right place to call any code specific to your data type that needs
 +   to run when the object is recycled -- e.g., free any additional
 +   resources allocated for it that are not Lisp objects.  You can even
 +   make a pointer to the function that frees the resources a slot in
 +   your object -- this way, the same object could be used to represent
 +   several disparate C structures.  */
 +
 +#ifdef CHECK_LISP_OBJECT_TYPE
 +
 +typedef struct { EMACS_INT i; } Lisp_Object;
 +
 +#define LISP_INITIALLY(i) {i}
 +
 +#undef CHECK_LISP_OBJECT_TYPE
 +enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = true };
 +#else /* CHECK_LISP_OBJECT_TYPE */
 +
 +/* If a struct type is not wanted, define Lisp_Object as just a number.  */
 +
 +typedef EMACS_INT Lisp_Object;
 +#define LISP_INITIALLY(i) (i)
 +enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = false };
 +#endif /* CHECK_LISP_OBJECT_TYPE */
 +
 +#define LISP_INITIALLY_ZERO LISP_INITIALLY (0)
 +
 +/* Forward declarations.  */
 +
 +/* Defined in this file.  */
 +union Lisp_Fwd;
 +INLINE bool BOOL_VECTOR_P (Lisp_Object);
 +INLINE bool BUFFER_OBJFWDP (union Lisp_Fwd *);
 +INLINE bool BUFFERP (Lisp_Object);
 +INLINE bool CHAR_TABLE_P (Lisp_Object);
 +INLINE Lisp_Object CHAR_TABLE_REF_ASCII (Lisp_Object, ptrdiff_t);
 +INLINE bool (CONSP) (Lisp_Object);
 +INLINE bool (FLOATP) (Lisp_Object);
 +INLINE bool functionp (Lisp_Object);
 +INLINE bool (INTEGERP) (Lisp_Object);
 +INLINE bool (MARKERP) (Lisp_Object);
 +INLINE bool (MISCP) (Lisp_Object);
 +INLINE bool (NILP) (Lisp_Object);
 +INLINE bool OVERLAYP (Lisp_Object);
 +INLINE bool PROCESSP (Lisp_Object);
 +INLINE bool PSEUDOVECTORP (Lisp_Object, int);
 +INLINE bool SAVE_VALUEP (Lisp_Object);
 +INLINE bool FINALIZERP (Lisp_Object);
 +INLINE void set_sub_char_table_contents (Lisp_Object, ptrdiff_t,
 +					      Lisp_Object);
 +INLINE bool STRINGP (Lisp_Object);
 +INLINE bool SUB_CHAR_TABLE_P (Lisp_Object);
 +INLINE bool SUBRP (Lisp_Object);
 +INLINE bool (SYMBOLP) (Lisp_Object);
 +INLINE bool (VECTORLIKEP) (Lisp_Object);
 +INLINE bool WINDOWP (Lisp_Object);
 +INLINE bool TERMINALP (Lisp_Object);
 +INLINE struct Lisp_Save_Value *XSAVE_VALUE (Lisp_Object);
 +INLINE struct Lisp_Finalizer *XFINALIZER (Lisp_Object);
 +INLINE struct Lisp_Symbol *(XSYMBOL) (Lisp_Object);
 +INLINE void *(XUNTAG) (Lisp_Object, int);
 +
 +/* Defined in chartab.c.  */
 +extern Lisp_Object char_table_ref (Lisp_Object, int);
 +extern void char_table_set (Lisp_Object, int, Lisp_Object);
 +
 +/* Defined in data.c.  */
 +extern _Noreturn Lisp_Object wrong_type_argument (Lisp_Object, Lisp_Object);
 +extern _Noreturn void wrong_choice (Lisp_Object, Lisp_Object);
 +
 +/* Defined in emacs.c.  */
 +extern bool might_dump;
 +/* True means Emacs has already been initialized.
 +   Used during startup to detect startup of dumped Emacs.  */
 +extern bool initialized;
 +
 +/* Defined in floatfns.c.  */
 +extern double extract_float (Lisp_Object);
 +
 +
 +/* Interned state of a symbol.  */
 +
 +enum symbol_interned
 +{
 +  SYMBOL_UNINTERNED = 0,
 +  SYMBOL_INTERNED = 1,
 +  SYMBOL_INTERNED_IN_INITIAL_OBARRAY = 2
 +};
 +
 +enum symbol_redirect
 +{
 +  SYMBOL_PLAINVAL  = 4,
 +  SYMBOL_VARALIAS  = 1,
 +  SYMBOL_LOCALIZED = 2,
 +  SYMBOL_FORWARDED = 3
 +};
 +
 +struct Lisp_Symbol
 +{
 +  bool_bf gcmarkbit : 1;
 +
 +  /* Indicates where the value can be found:
 +     0 : it's a plain var, the value is in the `value' field.
 +     1 : it's a varalias, the value is really in the `alias' symbol.
 +     2 : it's a localized var, the value is in the `blv' object.
 +     3 : it's a forwarding variable, the value is in `forward'.  */
 +  ENUM_BF (symbol_redirect) redirect : 3;
 +
 +  /* Non-zero means symbol is constant, i.e. changing its value
 +     should signal an error.  If the value is 3, then the var
 +     can be changed, but only by `defconst'.  */
 +  unsigned constant : 2;
 +
 +  /* Interned state of the symbol.  This is an enumerator from
 +     enum symbol_interned.  */
 +  unsigned interned : 2;
 +
 +  /* True means that this variable has been explicitly declared
 +     special (with `defvar' etc), and shouldn't be lexically bound.  */
 +  bool_bf declared_special : 1;
 +
 +  /* True if pointed to from purespace and hence can't be GC'd.  */
 +  bool_bf pinned : 1;
 +
 +  /* The symbol's name, as a Lisp string.  */
 +  Lisp_Object name;
 +
 +  /* Value of the symbol or Qunbound if unbound.  Which alternative of the
 +     union is used depends on the `redirect' field above.  */
 +  union {
 +    Lisp_Object value;
 +    struct Lisp_Symbol *alias;
 +    struct Lisp_Buffer_Local_Value *blv;
 +    union Lisp_Fwd *fwd;
 +  } val;
 +
 +  /* Function value of the symbol or Qnil if not fboundp.  */
 +  Lisp_Object function;
 +
 +  /* The symbol's property list.  */
 +  Lisp_Object plist;
 +
 +  /* Next symbol in obarray bucket, if the symbol is interned.  */
 +  struct Lisp_Symbol *next;
 +};
 +
 +/* Declare a Lisp-callable function.  The MAXARGS parameter has the same
 +   meaning as in the DEFUN macro, and is used to construct a prototype.  */
 +/* We can use the same trick as in the DEFUN macro to generate the
 +   appropriate prototype.  */
 +#define EXFUN(fnname, maxargs) \
 +  extern Lisp_Object fnname DEFUN_ARGS_ ## maxargs
 +
 +/* Note that the weird token-substitution semantics of ANSI C makes
 +   this work for MANY and UNEVALLED.  */
 +#define DEFUN_ARGS_MANY		(ptrdiff_t, Lisp_Object *)
 +#define DEFUN_ARGS_UNEVALLED	(Lisp_Object)
 +#define DEFUN_ARGS_0	(void)
 +#define DEFUN_ARGS_1	(Lisp_Object)
 +#define DEFUN_ARGS_2	(Lisp_Object, Lisp_Object)
 +#define DEFUN_ARGS_3	(Lisp_Object, Lisp_Object, Lisp_Object)
 +#define DEFUN_ARGS_4	(Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object)
 +#define DEFUN_ARGS_5	(Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \
 +			 Lisp_Object)
 +#define DEFUN_ARGS_6	(Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \
 +			 Lisp_Object, Lisp_Object)
 +#define DEFUN_ARGS_7	(Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \
 +			 Lisp_Object, Lisp_Object, Lisp_Object)
 +#define DEFUN_ARGS_8	(Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \
 +			 Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object)
 +
 +/* Yield an integer that contains TAG along with PTR.  */
 +#define TAG_PTR(tag, ptr) \
 +  ((USE_LSB_TAG ? (tag) : (EMACS_UINT) (tag) << VALBITS) + (uintptr_t) (ptr))
 +
 +/* Yield an integer that contains a symbol tag along with OFFSET.
 +   OFFSET should be the offset in bytes from 'lispsym' to the symbol.  */
 +#define TAG_SYMOFFSET(offset)				    \
 +  TAG_PTR (Lisp_Symbol,					    \
 +	   ((uintptr_t) (offset) >> (USE_LSB_TAG ? 0 : GCTYPEBITS)))
 +
 +/* XLI_BUILTIN_LISPSYM (iQwhatever) is equivalent to
 +   XLI (builtin_lisp_symbol (Qwhatever)),
 +   except the former expands to an integer constant expression.  */
 +#define XLI_BUILTIN_LISPSYM(iname) TAG_SYMOFFSET ((iname) * sizeof *lispsym)
 +
 +/* Declare extern constants for Lisp symbols.  These can be helpful
 +   when using a debugger like GDB, on older platforms where the debug
 +   format does not represent C macros.  */
 +#define DEFINE_LISP_SYMBOL(name) \
 +  DEFINE_GDB_SYMBOL_BEGIN (Lisp_Object, name) \
 +  DEFINE_GDB_SYMBOL_END (LISP_INITIALLY (XLI_BUILTIN_LISPSYM (i##name)))
 +
 +/* By default, define macros for Qt, etc., as this leads to a bit
 +   better performance in the core Emacs interpreter.  A plugin can
 +   define DEFINE_NON_NIL_Q_SYMBOL_MACROS to be false, to be portable to
 +   other Emacs instances that assign different values to Qt, etc.  */
 +#ifndef DEFINE_NON_NIL_Q_SYMBOL_MACROS
 +# define DEFINE_NON_NIL_Q_SYMBOL_MACROS true
 +#endif
 +
 +#include "globals.h"
 +
 +/* Convert a Lisp_Object to the corresponding EMACS_INT and vice versa.
 +   At the machine level, these operations are no-ops.  */
 +LISP_MACRO_DEFUN (XLI, EMACS_INT, (Lisp_Object o), (o))
 +LISP_MACRO_DEFUN (XIL, Lisp_Object, (EMACS_INT i), (i))
 +
 +/* In the size word of a vector, this bit means the vector has been marked.  */
 +
 +DEFINE_GDB_SYMBOL_BEGIN (ptrdiff_t, ARRAY_MARK_FLAG)
 +# define ARRAY_MARK_FLAG PTRDIFF_MIN
 +DEFINE_GDB_SYMBOL_END (ARRAY_MARK_FLAG)
 +
 +/* In the size word of a struct Lisp_Vector, this bit means it's really
 +   some other vector-like object.  */
 +DEFINE_GDB_SYMBOL_BEGIN (ptrdiff_t, PSEUDOVECTOR_FLAG)
 +# define PSEUDOVECTOR_FLAG (PTRDIFF_MAX - PTRDIFF_MAX / 2)
 +DEFINE_GDB_SYMBOL_END (PSEUDOVECTOR_FLAG)
 +
 +/* In a pseudovector, the size field actually contains a word with one
 +   PSEUDOVECTOR_FLAG bit set, and one of the following values extracted
 +   with PVEC_TYPE_MASK to indicate the actual type.  */
 +enum pvec_type
 +{
 +  PVEC_NORMAL_VECTOR,
 +  PVEC_FREE,
 +  PVEC_PROCESS,
 +  PVEC_FRAME,
 +  PVEC_WINDOW,
 +  PVEC_BOOL_VECTOR,
 +  PVEC_BUFFER,
 +  PVEC_HASH_TABLE,
 +  PVEC_TERMINAL,
 +  PVEC_WINDOW_CONFIGURATION,
 +  PVEC_SUBR,
 +  PVEC_OTHER,
 +  /* These should be last, check internal_equal to see why.  */
 +  PVEC_COMPILED,
 +  PVEC_CHAR_TABLE,
 +  PVEC_SUB_CHAR_TABLE,
 +  PVEC_FONT /* Should be last because it's used for range checking.  */
 +};
 +
 +enum More_Lisp_Bits
 +  {
 +    /* For convenience, we also store the number of elements in these bits.
 +       Note that this size is not necessarily the memory-footprint size, but
 +       only the number of Lisp_Object fields (that need to be traced by GC).
 +       The distinction is used, e.g., by Lisp_Process, which places extra
 +       non-Lisp_Object fields at the end of the structure.  */
 +    PSEUDOVECTOR_SIZE_BITS = 12,
 +    PSEUDOVECTOR_SIZE_MASK = (1 << PSEUDOVECTOR_SIZE_BITS) - 1,
 +
 +    /* To calculate the memory footprint of the pseudovector, it's useful
 +       to store the size of non-Lisp area in word_size units here.  */
 +    PSEUDOVECTOR_REST_BITS = 12,
 +    PSEUDOVECTOR_REST_MASK = (((1 << PSEUDOVECTOR_REST_BITS) - 1)
 +			      << PSEUDOVECTOR_SIZE_BITS),
 +
 +    /* Used to extract pseudovector subtype information.  */
 +    PSEUDOVECTOR_AREA_BITS = PSEUDOVECTOR_SIZE_BITS + PSEUDOVECTOR_REST_BITS,
 +    PVEC_TYPE_MASK = 0x3f << PSEUDOVECTOR_AREA_BITS
 +  };
 +
 +/* These functions extract various sorts of values from a Lisp_Object.
 +   For example, if tem is a Lisp_Object whose type is Lisp_Cons,
 +   XCONS (tem) is the struct Lisp_Cons * pointing to the memory for
 +   that cons.  */
 +
 +/* Mask for the value (as opposed to the type bits) of a Lisp object.  */
 +DEFINE_GDB_SYMBOL_BEGIN (EMACS_INT, VALMASK)
 +# define VALMASK (USE_LSB_TAG ? - (1 << GCTYPEBITS) : VAL_MAX)
 +DEFINE_GDB_SYMBOL_END (VALMASK)
 +
 +/* Largest and smallest representable fixnum values.  These are the C
 +   values.  They are macros for use in static initializers.  */
 +#define MOST_POSITIVE_FIXNUM (EMACS_INT_MAX >> INTTYPEBITS)
 +#define MOST_NEGATIVE_FIXNUM (-1 - MOST_POSITIVE_FIXNUM)
 +
 +#if USE_LSB_TAG
 +
 +LISP_MACRO_DEFUN (make_number, Lisp_Object, (EMACS_INT n), (n))
 +LISP_MACRO_DEFUN (XINT, EMACS_INT, (Lisp_Object a), (a))
 +LISP_MACRO_DEFUN (XFASTINT, EMACS_INT, (Lisp_Object a), (a))
 +LISP_MACRO_DEFUN (XSYMBOL, struct Lisp_Symbol *, (Lisp_Object a), (a))
 +LISP_MACRO_DEFUN (XTYPE, enum Lisp_Type, (Lisp_Object a), (a))
 +LISP_MACRO_DEFUN (XUNTAG, void *, (Lisp_Object a, int type), (a, type))
 +
 +#else /* ! USE_LSB_TAG */
 +
 +/* Although compiled only if ! USE_LSB_TAG, the following functions
 +   also work when USE_LSB_TAG; this is to aid future maintenance when
 +   the lisp_h_* macros are eventually removed.  */
 +
 +/* Make a Lisp integer representing the value of the low order
 +   bits of N.  */
 +INLINE Lisp_Object
 +make_number (EMACS_INT n)
 +{
 +  EMACS_INT int0 = Lisp_Int0;
 +  if (USE_LSB_TAG)
 +    {
 +      EMACS_UINT u = n;
 +      n = u << INTTYPEBITS;
 +      n += int0;
 +    }
 +  else
 +    {
 +      n &= INTMASK;
 +      n += (int0 << VALBITS);
 +    }
 +  return XIL (n);
 +}
 +
 +/* Extract A's value as a signed integer.  */
 +INLINE EMACS_INT
 +XINT (Lisp_Object a)
 +{
 +  EMACS_INT i = XLI (a);
 +  if (! USE_LSB_TAG)
 +    {
 +      EMACS_UINT u = i;
 +      i = u << INTTYPEBITS;
 +    }
 +  return i >> INTTYPEBITS;
 +}
 +
 +/* Like XINT (A), but may be faster.  A must be nonnegative.
 +   If ! USE_LSB_TAG, this takes advantage of the fact that Lisp
 +   integers have zero-bits in their tags.  */
 +INLINE EMACS_INT
 +XFASTINT (Lisp_Object a)
 +{
 +  EMACS_INT int0 = Lisp_Int0;
 +  EMACS_INT n = USE_LSB_TAG ? XINT (a) : XLI (a) - (int0 << VALBITS);
 +  eassert (0 <= n);
 +  return n;
 +}
 +
 +/* Extract A's value as a symbol.  */
 +INLINE struct Lisp_Symbol *
 +XSYMBOL (Lisp_Object a)
 +{
 +  uintptr_t i = (uintptr_t) XUNTAG (a, Lisp_Symbol);
 +  if (! USE_LSB_TAG)
 +    i <<= GCTYPEBITS;
 +  void *p = (char *) lispsym + i;
 +  return p;
 +}
 +
 +/* Extract A's type.  */
 +INLINE enum Lisp_Type
 +XTYPE (Lisp_Object a)
 +{
 +  EMACS_UINT i = XLI (a);
 +  return USE_LSB_TAG ? i & ~VALMASK : i >> VALBITS;
 +}
 +
 +/* Extract A's pointer value, assuming A's type is TYPE.  */
 +INLINE void *
 +XUNTAG (Lisp_Object a, int type)
 +{
 +  intptr_t i = USE_LSB_TAG ? XLI (a) - type : XLI (a) & VALMASK;
 +  return (void *) i;
 +}
 +
 +#endif /* ! USE_LSB_TAG */
 +
 +/* Extract the pointer hidden within A.  */
 +LISP_MACRO_DEFUN (XPNTR, void *, (Lisp_Object a), (a))
 +
 +/* Extract A's value as an unsigned integer.  */
 +INLINE EMACS_UINT
 +XUINT (Lisp_Object a)
 +{
 +  EMACS_UINT i = XLI (a);
 +  return USE_LSB_TAG ? i >> INTTYPEBITS : i & INTMASK;
 +}
 +
 +/* Return A's (Lisp-integer sized) hash.  Happens to be like XUINT
 +   right now, but XUINT should only be applied to objects we know are
 +   integers.  */
 +LISP_MACRO_DEFUN (XHASH, EMACS_INT, (Lisp_Object a), (a))
 +
 +/* Like make_number (N), but may be faster.  N must be in nonnegative range.  */
 +INLINE Lisp_Object
 +make_natnum (EMACS_INT n)
 +{
 +  eassert (0 <= n && n <= MOST_POSITIVE_FIXNUM);
 +  EMACS_INT int0 = Lisp_Int0;
 +  return USE_LSB_TAG ? make_number (n) : XIL (n + (int0 << VALBITS));
 +}
 +
 +/* Return true if X and Y are the same object.  */
 +LISP_MACRO_DEFUN (EQ, bool, (Lisp_Object x, Lisp_Object y), (x, y))
 +
 +/* Value is true if I doesn't fit into a Lisp fixnum.  It is
 +   written this way so that it also works if I is of unsigned
 +   type or if I is a NaN.  */
 +
 +#define FIXNUM_OVERFLOW_P(i) \
 +  (! ((0 <= (i) || MOST_NEGATIVE_FIXNUM <= (i)) && (i) <= MOST_POSITIVE_FIXNUM))
 +
 +INLINE ptrdiff_t
 +clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper)
 +{
 +  return num < lower ? lower : num <= upper ? num : upper;
 +}
 +
 +
 +/* Extract a value or address from a Lisp_Object.  */
 +
 +LISP_MACRO_DEFUN (XCONS, struct Lisp_Cons *, (Lisp_Object a), (a))
 +
 +INLINE struct Lisp_Vector *
 +XVECTOR (Lisp_Object a)
 +{
 +  eassert (VECTORLIKEP (a));
 +  return XUNTAG (a, Lisp_Vectorlike);
 +}
 +
 +INLINE struct Lisp_String *
 +XSTRING (Lisp_Object a)
 +{
 +  eassert (STRINGP (a));
 +  return XUNTAG (a, Lisp_String);
 +}
 +
 +/* The index of the C-defined Lisp symbol SYM.
 +   This can be used in a static initializer.  */
 +#define SYMBOL_INDEX(sym) i##sym
 +
 +INLINE struct Lisp_Float *
 +XFLOAT (Lisp_Object a)
 +{
 +  eassert (FLOATP (a));
 +  return XUNTAG (a, Lisp_Float);
 +}
 +
 +/* Pseudovector types.  */
 +
 +INLINE struct Lisp_Process *
 +XPROCESS (Lisp_Object a)
 +{
 +  eassert (PROCESSP (a));
 +  return XUNTAG (a, Lisp_Vectorlike);
 +}
 +
 +INLINE struct window *
 +XWINDOW (Lisp_Object a)
 +{
 +  eassert (WINDOWP (a));
 +  return XUNTAG (a, Lisp_Vectorlike);
 +}
 +
 +INLINE struct terminal *
 +XTERMINAL (Lisp_Object a)
 +{
 +  eassert (TERMINALP (a));
 +  return XUNTAG (a, Lisp_Vectorlike);
 +}
 +
 +INLINE struct Lisp_Subr *
 +XSUBR (Lisp_Object a)
 +{
 +  eassert (SUBRP (a));
 +  return XUNTAG (a, Lisp_Vectorlike);
 +}
 +
 +INLINE struct buffer *
 +XBUFFER (Lisp_Object a)
 +{
 +  eassert (BUFFERP (a));
 +  return XUNTAG (a, Lisp_Vectorlike);
 +}
 +
 +INLINE struct Lisp_Char_Table *
 +XCHAR_TABLE (Lisp_Object a)
 +{
 +  eassert (CHAR_TABLE_P (a));
 +  return XUNTAG (a, Lisp_Vectorlike);
 +}
 +
 +INLINE struct Lisp_Sub_Char_Table *
 +XSUB_CHAR_TABLE (Lisp_Object a)
 +{
 +  eassert (SUB_CHAR_TABLE_P (a));
 +  return XUNTAG (a, Lisp_Vectorlike);
 +}
 +
 +INLINE struct Lisp_Bool_Vector *
 +XBOOL_VECTOR (Lisp_Object a)
 +{
 +  eassert (BOOL_VECTOR_P (a));
 +  return XUNTAG (a, Lisp_Vectorlike);
 +}
 +
 +/* Construct a Lisp_Object from a value or address.  */
 +
 +INLINE Lisp_Object
 +make_lisp_ptr (void *ptr, enum Lisp_Type type)
 +{
 +  Lisp_Object a = XIL (TAG_PTR (type, ptr));
 +  eassert (XTYPE (a) == type && XUNTAG (a, type) == ptr);
 +  return a;
 +}
 +
 +INLINE Lisp_Object
 +make_lisp_symbol (struct Lisp_Symbol *sym)
 +{
 +  Lisp_Object a = XIL (TAG_SYMOFFSET ((char *) sym - (char *) lispsym));
 +  eassert (XSYMBOL (a) == sym);
 +  return a;
 +}
 +
 +INLINE Lisp_Object
 +builtin_lisp_symbol (int index)
 +{
 +  return make_lisp_symbol (lispsym + index);
 +}
 +
 +#define XSETINT(a, b) ((a) = make_number (b))
 +#define XSETFASTINT(a, b) ((a) = make_natnum (b))
 +#define XSETCONS(a, b) ((a) = make_lisp_ptr (b, Lisp_Cons))
 +#define XSETVECTOR(a, b) ((a) = make_lisp_ptr (b, Lisp_Vectorlike))
 +#define XSETSTRING(a, b) ((a) = make_lisp_ptr (b, Lisp_String))
 +#define XSETSYMBOL(a, b) ((a) = make_lisp_symbol (b))
 +#define XSETFLOAT(a, b) ((a) = make_lisp_ptr (b, Lisp_Float))
 +#define XSETMISC(a, b) ((a) = make_lisp_ptr (b, Lisp_Misc))
 +
 +/* Pseudovector types.  */
 +
 +#define XSETPVECTYPE(v, code)						\
 +  ((v)->header.size |= PSEUDOVECTOR_FLAG | ((code) << PSEUDOVECTOR_AREA_BITS))
 +#define XSETPVECTYPESIZE(v, code, lispsize, restsize)		\
 +  ((v)->header.size = (PSEUDOVECTOR_FLAG			\
 +		       | ((code) << PSEUDOVECTOR_AREA_BITS)	\
 +		       | ((restsize) << PSEUDOVECTOR_SIZE_BITS) \
 +		       | (lispsize)))
 +
 +/* The cast to struct vectorlike_header * avoids aliasing issues.  */
 +#define XSETPSEUDOVECTOR(a, b, code) \
 +  XSETTYPED_PSEUDOVECTOR (a, b,					\
 +			  (((struct vectorlike_header *)	\
 +			    XUNTAG (a, Lisp_Vectorlike))	\
 +			   ->size),				\
 +			  code)
 +#define XSETTYPED_PSEUDOVECTOR(a, b, size, code)			\
 +  (XSETVECTOR (a, b),							\
 +   eassert ((size & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK))		\
 +	    == (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS))))
 +
 +#define XSETWINDOW_CONFIGURATION(a, b) \
 +  (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW_CONFIGURATION))
 +#define XSETPROCESS(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_PROCESS))
 +#define XSETWINDOW(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW))
 +#define XSETTERMINAL(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_TERMINAL))
 +#define XSETSUBR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUBR))
 +#define XSETCOMPILED(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_COMPILED))
 +#define XSETBUFFER(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BUFFER))
 +#define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE))
 +#define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR))
 +#define XSETSUB_CHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUB_CHAR_TABLE))
 +
 +/* Efficiently convert a pointer to a Lisp object and back.  The
 +   pointer is represented as a Lisp integer, so the garbage collector
 +   does not know about it.  The pointer should not have both Lisp_Int1
 +   bits set, which makes this conversion inherently unportable.  */
 +
 +INLINE void *
 +XINTPTR (Lisp_Object a)
 +{
 +  return XUNTAG (a, Lisp_Int0);
 +}
 +
 +INLINE Lisp_Object
 +make_pointer_integer (void *p)
 +{
 +  Lisp_Object a = XIL (TAG_PTR (Lisp_Int0, p));
 +  eassert (INTEGERP (a) && XINTPTR (a) == p);
 +  return a;
 +}
 +
 +/* Type checking.  */
 +
 +LISP_MACRO_DEFUN_VOID (CHECK_TYPE,
 +		       (int ok, Lisp_Object predicate, Lisp_Object x),
 +		       (ok, predicate, x))
 +
 +/* See the macros in intervals.h.  */
 +
 +typedef struct interval *INTERVAL;
 +
 +struct GCALIGNED Lisp_Cons
 +  {
 +    /* Car of this cons cell.  */
 +    Lisp_Object car;
 +
 +    union
 +    {
 +      /* Cdr of this cons cell.  */
 +      Lisp_Object cdr;
 +
 +      /* Used to chain conses on a free list.  */
 +      struct Lisp_Cons *chain;
 +    } u;
 +  };
 +
 +/* Take the car or cdr of something known to be a cons cell.  */
 +/* The _addr functions shouldn't be used outside of the minimal set
 +   of code that has to know what a cons cell looks like.  Other code not
 +   part of the basic lisp implementation should assume that the car and cdr
 +   fields are not accessible.  (What if we want to switch to
 +   a copying collector someday?  Cached cons cell field addresses may be
 +   invalidated at arbitrary points.)  */
 +INLINE Lisp_Object *
 +xcar_addr (Lisp_Object c)
 +{
 +  return &XCONS (c)->car;
 +}
 +INLINE Lisp_Object *
 +xcdr_addr (Lisp_Object c)
 +{
 +  return &XCONS (c)->u.cdr;
 +}
 +
 +/* Use these from normal code.  */
 +LISP_MACRO_DEFUN (XCAR, Lisp_Object, (Lisp_Object c), (c))
 +LISP_MACRO_DEFUN (XCDR, Lisp_Object, (Lisp_Object c), (c))
 +
 +/* Use these to set the fields of a cons cell.
 +
 +   Note that both arguments may refer to the same object, so 'n'
 +   should not be read after 'c' is first modified.  */
 +INLINE void
 +XSETCAR (Lisp_Object c, Lisp_Object n)
 +{
 +  *xcar_addr (c) = n;
 +}
 +INLINE void
 +XSETCDR (Lisp_Object c, Lisp_Object n)
 +{
 +  *xcdr_addr (c) = n;
 +}
 +
 +/* Take the car or cdr of something whose type is not known.  */
 +INLINE Lisp_Object
 +CAR (Lisp_Object c)
 +{
 +  return (CONSP (c) ? XCAR (c)
 +	  : NILP (c) ? Qnil
 +	  : wrong_type_argument (Qlistp, c));
 +}
 +INLINE Lisp_Object
 +CDR (Lisp_Object c)
 +{
 +  return (CONSP (c) ? XCDR (c)
 +	  : NILP (c) ? Qnil
 +	  : wrong_type_argument (Qlistp, c));
 +}
 +
 +/* Take the car or cdr of something whose type is not known.  */
 +INLINE Lisp_Object
 +CAR_SAFE (Lisp_Object c)
 +{
 +  return CONSP (c) ? XCAR (c) : Qnil;
 +}
 +INLINE Lisp_Object
 +CDR_SAFE (Lisp_Object c)
 +{
 +  return CONSP (c) ? XCDR (c) : Qnil;
 +}
 +
 +/* In a string or vector, the sign bit of the `size' is the gc mark bit.  */
 +
 +struct GCALIGNED Lisp_String
 +  {
 +    ptrdiff_t size;
 +    ptrdiff_t size_byte;
 +    INTERVAL intervals;		/* Text properties in this string.  */
 +    unsigned char *data;
 +  };
 +
 +/* True if STR is a multibyte string.  */
 +INLINE bool
 +STRING_MULTIBYTE (Lisp_Object str)
 +{
 +  return 0 <= XSTRING (str)->size_byte;
 +}
 +
 +/* An upper bound on the number of bytes in a Lisp string, not
 +   counting the terminating null.  This a tight enough bound to
 +   prevent integer overflow errors that would otherwise occur during
 +   string size calculations.  A string cannot contain more bytes than
 +   a fixnum can represent, nor can it be so long that C pointer
 +   arithmetic stops working on the string plus its terminating null.
 +   Although the actual size limit (see STRING_BYTES_MAX in alloc.c)
 +   may be a bit smaller than STRING_BYTES_BOUND, calculating it here
 +   would expose alloc.c internal details that we'd rather keep
 +   private.
 +
 +   This is a macro for use in static initializers.  The cast to
 +   ptrdiff_t ensures that the macro is signed.  */
 +#define STRING_BYTES_BOUND  \
 +  ((ptrdiff_t) min (MOST_POSITIVE_FIXNUM, min (SIZE_MAX, PTRDIFF_MAX) - 1))
 +
 +/* Mark STR as a unibyte string.  */
 +#define STRING_SET_UNIBYTE(STR)				\
 +  do {							\
 +    if (EQ (STR, empty_multibyte_string))		\
 +      (STR) = empty_unibyte_string;			\
 +    else						\
 +      XSTRING (STR)->size_byte = -1;			\
 +  } while (false)
 +
 +/* Mark STR as a multibyte string.  Assure that STR contains only
 +   ASCII characters in advance.  */
 +#define STRING_SET_MULTIBYTE(STR)			\
 +  do {							\
 +    if (EQ (STR, empty_unibyte_string))			\
 +      (STR) = empty_multibyte_string;			\
 +    else						\
 +      XSTRING (STR)->size_byte = XSTRING (STR)->size;	\
 +  } while (false)
 +
 +/* Convenience functions for dealing with Lisp strings.  */
 +
 +INLINE unsigned char *
 +SDATA (Lisp_Object string)
 +{
 +  return XSTRING (string)->data;
 +}
 +INLINE char *
 +SSDATA (Lisp_Object string)
 +{
 +  /* Avoid "differ in sign" warnings.  */
 +  return (char *) SDATA (string);
 +}
 +INLINE unsigned char
 +SREF (Lisp_Object string, ptrdiff_t index)
 +{
 +  return SDATA (string)[index];
 +}
 +INLINE void
 +SSET (Lisp_Object string, ptrdiff_t index, unsigned char new)
 +{
 +  SDATA (string)[index] = new;
 +}
 +INLINE ptrdiff_t
 +SCHARS (Lisp_Object string)
 +{
 +  return XSTRING (string)->size;
 +}
 +
 +#ifdef GC_CHECK_STRING_BYTES
 +extern ptrdiff_t string_bytes (struct Lisp_String *);
 +#endif
 +INLINE ptrdiff_t
 +STRING_BYTES (struct Lisp_String *s)
 +{
 +#ifdef GC_CHECK_STRING_BYTES
 +  return string_bytes (s);
 +#else
 +  return s->size_byte < 0 ? s->size : s->size_byte;
 +#endif
 +}
 +
 +INLINE ptrdiff_t
 +SBYTES (Lisp_Object string)
 +{
 +  return STRING_BYTES (XSTRING (string));
 +}
 +INLINE void
 +STRING_SET_CHARS (Lisp_Object string, ptrdiff_t newsize)
 +{
 +  XSTRING (string)->size = newsize;
 +}
 +
 +/* Header of vector-like objects.  This documents the layout constraints on
 +   vectors and pseudovectors (objects of PVEC_xxx subtype).  It also prevents
 +   compilers from being fooled by Emacs's type punning: XSETPSEUDOVECTOR
 +   and PSEUDOVECTORP cast their pointers to struct vectorlike_header *,
 +   because when two such pointers potentially alias, a compiler won't
 +   incorrectly reorder loads and stores to their size fields.  See
 +   Bug#8546.  */
 +struct vectorlike_header
 +  {
 +    /* The only field contains various pieces of information:
 +       - The MSB (ARRAY_MARK_FLAG) holds the gcmarkbit.
 +       - The next bit (PSEUDOVECTOR_FLAG) indicates whether this is a plain
 +         vector (0) or a pseudovector (1).
 +       - If PSEUDOVECTOR_FLAG is 0, the rest holds the size (number
 +         of slots) of the vector.
 +       - If PSEUDOVECTOR_FLAG is 1, the rest is subdivided into three fields:
 +	 - a) pseudovector subtype held in PVEC_TYPE_MASK field;
 +	 - b) number of Lisp_Objects slots at the beginning of the object
 +	   held in PSEUDOVECTOR_SIZE_MASK field.  These objects are always
 +	   traced by the GC;
 +	 - c) size of the rest fields held in PSEUDOVECTOR_REST_MASK and
 +	   measured in word_size units.  Rest fields may also include
 +	   Lisp_Objects, but these objects usually needs some special treatment
 +	   during GC.
 +	 There are some exceptions.  For PVEC_FREE, b) is always zero.  For
 +	 PVEC_BOOL_VECTOR and PVEC_SUBR, both b) and c) are always zero.
 +	 Current layout limits the pseudovectors to 63 PVEC_xxx subtypes,
 +	 4095 Lisp_Objects in GC-ed area and 4095 word-sized other slots.  */
 +    ptrdiff_t size;
 +  };
 +
 +/* A regular vector is just a header plus an array of Lisp_Objects.  */
 +
 +struct Lisp_Vector
 +  {
 +    struct vectorlike_header header;
 +    Lisp_Object contents[FLEXIBLE_ARRAY_MEMBER];
 +  };
 +
 +/* C11 prohibits alignof (struct Lisp_Vector), so compute it manually.  */
 +enum
 +  {
 +    ALIGNOF_STRUCT_LISP_VECTOR
 +      = alignof (union { struct vectorlike_header a; Lisp_Object b; })
 +  };
 +
 +/* A boolvector is a kind of vectorlike, with contents like a string.  */
 +
 +struct Lisp_Bool_Vector
 +  {
 +    /* HEADER.SIZE is the vector's size field.  It doesn't have the real size,
 +       just the subtype information.  */
 +    struct vectorlike_header header;
 +    /* This is the size in bits.  */
 +    EMACS_INT size;
 +    /* The actual bits, packed into bytes.
 +       Zeros fill out the last word if needed.
 +       The bits are in little-endian order in the bytes, and
 +       the bytes are in little-endian order in the words.  */
 +    bits_word data[FLEXIBLE_ARRAY_MEMBER];
 +  };
 +
 +INLINE EMACS_INT
 +bool_vector_size (Lisp_Object a)
 +{
 +  EMACS_INT size = XBOOL_VECTOR (a)->size;
 +  eassume (0 <= size);
 +  return size;
 +}
 +
 +INLINE bits_word *
 +bool_vector_data (Lisp_Object a)
 +{
 +  return XBOOL_VECTOR (a)->data;
 +}
 +
 +INLINE unsigned char *
 +bool_vector_uchar_data (Lisp_Object a)
 +{
 +  return (unsigned char *) bool_vector_data (a);
 +}
 +
 +/* The number of data words and bytes in a bool vector with SIZE bits.  */
 +
 +INLINE EMACS_INT
 +bool_vector_words (EMACS_INT size)
 +{
 +  eassume (0 <= size && size <= EMACS_INT_MAX - (BITS_PER_BITS_WORD - 1));
 +  return (size + BITS_PER_BITS_WORD - 1) / BITS_PER_BITS_WORD;
 +}
 +
 +INLINE EMACS_INT
 +bool_vector_bytes (EMACS_INT size)
 +{
 +  eassume (0 <= size && size <= EMACS_INT_MAX - (BITS_PER_BITS_WORD - 1));
 +  return (size + BOOL_VECTOR_BITS_PER_CHAR - 1) / BOOL_VECTOR_BITS_PER_CHAR;
 +}
 +
 +/* True if A's Ith bit is set.  */
 +
 +INLINE bool
 +bool_vector_bitref (Lisp_Object a, EMACS_INT i)
 +{
 +  eassume (0 <= i && i < bool_vector_size (a));
 +  return !! (bool_vector_uchar_data (a)[i / BOOL_VECTOR_BITS_PER_CHAR]
 +	     & (1 << (i % BOOL_VECTOR_BITS_PER_CHAR)));
 +}
 +
 +INLINE Lisp_Object
 +bool_vector_ref (Lisp_Object a, EMACS_INT i)
 +{
 +  return bool_vector_bitref (a, i) ? Qt : Qnil;
 +}
 +
 +/* Set A's Ith bit to B.  */
 +
 +INLINE void
 +bool_vector_set (Lisp_Object a, EMACS_INT i, bool b)
 +{
 +  unsigned char *addr;
 +
 +  eassume (0 <= i && i < bool_vector_size (a));
 +  addr = &bool_vector_uchar_data (a)[i / BOOL_VECTOR_BITS_PER_CHAR];
 +
 +  if (b)
 +    *addr |= 1 << (i % BOOL_VECTOR_BITS_PER_CHAR);
 +  else
 +    *addr &= ~ (1 << (i % BOOL_VECTOR_BITS_PER_CHAR));
 +}
 +
 +/* Some handy constants for calculating sizes
 +   and offsets, mostly of vectorlike objects.   */
 +
 +enum
 +  {
 +    header_size = offsetof (struct Lisp_Vector, contents),
 +    bool_header_size = offsetof (struct Lisp_Bool_Vector, data),
 +    word_size = sizeof (Lisp_Object)
 +  };
 +
 +/* Conveniences for dealing with Lisp arrays.  */
 +
 +INLINE Lisp_Object
 +AREF (Lisp_Object array, ptrdiff_t idx)
 +{
 +  return XVECTOR (array)->contents[idx];
 +}
 +
 +INLINE Lisp_Object *
 +aref_addr (Lisp_Object array, ptrdiff_t idx)
 +{
 +  return & XVECTOR (array)->contents[idx];
 +}
 +
 +INLINE ptrdiff_t
 +ASIZE (Lisp_Object array)
 +{
 +  return XVECTOR (array)->header.size;
 +}
 +
 +INLINE void
 +ASET (Lisp_Object array, ptrdiff_t idx, Lisp_Object val)
 +{
 +  eassert (0 <= idx && idx < ASIZE (array));
 +  XVECTOR (array)->contents[idx] = val;
 +}
 +
 +INLINE void
 +gc_aset (Lisp_Object array, ptrdiff_t idx, Lisp_Object val)
 +{
 +  /* Like ASET, but also can be used in the garbage collector:
 +     sweep_weak_table calls set_hash_key etc. while the table is marked.  */
 +  eassert (0 <= idx && idx < (ASIZE (array) & ~ARRAY_MARK_FLAG));
 +  XVECTOR (array)->contents[idx] = val;
 +}
 +
 +/* True, since Qnil's representation is zero.  Every place in the code
 +   that assumes Qnil is zero should verify (NIL_IS_ZERO), to make it easy
 +   to find such assumptions later if we change Qnil to be nonzero.  */
 +enum { NIL_IS_ZERO = XLI_BUILTIN_LISPSYM (iQnil) == 0 };
 +
 +/* Clear the object addressed by P, with size NBYTES, so that all its
 +   bytes are zero and all its Lisp values are nil.  */
 +INLINE void
 +memclear (void *p, ptrdiff_t nbytes)
 +{
 +  eassert (0 <= nbytes);
 +  verify (NIL_IS_ZERO);
 +  /* Since Qnil is zero, memset suffices.  */
 +  memset (p, 0, nbytes);
 +}
 +
 +/* If a struct is made to look like a vector, this macro returns the length
 +   of the shortest vector that would hold that struct.  */
 +
 +#define VECSIZE(type)						\
 +  ((sizeof (type) - header_size + word_size - 1) / word_size)
 +
 +/* Like VECSIZE, but used when the pseudo-vector has non-Lisp_Object fields
 +   at the end and we need to compute the number of Lisp_Object fields (the
 +   ones that the GC needs to trace).  */
 +
 +#define PSEUDOVECSIZE(type, nonlispfield)			\
 +  ((offsetof (type, nonlispfield) - header_size) / word_size)
 +
 +/* Compute A OP B, using the unsigned comparison operator OP.  A and B
 +   should be integer expressions.  This is not the same as
 +   mathematical comparison; for example, UNSIGNED_CMP (0, <, -1)
 +   returns true.  For efficiency, prefer plain unsigned comparison if A
 +   and B's sizes both fit (after integer promotion).  */
 +#define UNSIGNED_CMP(a, op, b)						\
 +  (max (sizeof ((a) + 0), sizeof ((b) + 0)) <= sizeof (unsigned)	\
 +   ? ((a) + (unsigned) 0) op ((b) + (unsigned) 0)			\
 +   : ((a) + (uintmax_t) 0) op ((b) + (uintmax_t) 0))
 +
 +/* True iff C is an ASCII character.  */
 +#define ASCII_CHAR_P(c) UNSIGNED_CMP (c, <, 0x80)
 +
 +/* A char-table is a kind of vectorlike, with contents are like a
 +   vector but with a few other slots.  For some purposes, it makes
 +   sense to handle a char-table with type struct Lisp_Vector.  An
 +   element of a char table can be any Lisp objects, but if it is a sub
 +   char-table, we treat it a table that contains information of a
 +   specific range of characters.  A sub char-table is like a vector but
 +   with two integer fields between the header and Lisp data, which means
 +   that it has to be marked with some precautions (see mark_char_table
 +   in alloc.c).  A sub char-table appears only in an element of a char-table,
 +   and there's no way to access it directly from Emacs Lisp program.  */
 +
 +enum CHARTAB_SIZE_BITS
 +  {
 +    CHARTAB_SIZE_BITS_0 = 6,
 +    CHARTAB_SIZE_BITS_1 = 4,
 +    CHARTAB_SIZE_BITS_2 = 5,
 +    CHARTAB_SIZE_BITS_3 = 7
 +  };
 +
 +extern const int chartab_size[4];
 +
 +struct Lisp_Char_Table
 +  {
 +    /* HEADER.SIZE is the vector's size field, which also holds the
 +       pseudovector type information.  It holds the size, too.
 +       The size counts the defalt, parent, purpose, ascii,
 +       contents, and extras slots.  */
 +    struct vectorlike_header header;
 +
 +    /* This holds a default value,
 +       which is used whenever the value for a specific character is nil.  */
 +    Lisp_Object defalt;
 +
 +    /* This points to another char table, which we inherit from when the
 +       value for a specific character is nil.  The `defalt' slot takes
 +       precedence over this.  */
 +    Lisp_Object parent;
 +
 +    /* This is a symbol which says what kind of use this char-table is
 +       meant for.  */
 +    Lisp_Object purpose;
 +
 +    /* The bottom sub char-table for characters of the range 0..127.  It
 +       is nil if none of ASCII character has a specific value.  */
 +    Lisp_Object ascii;
 +
 +    Lisp_Object contents[(1 << CHARTAB_SIZE_BITS_0)];
 +
 +    /* These hold additional data.  It is a vector.  */
 +    Lisp_Object extras[FLEXIBLE_ARRAY_MEMBER];
 +  };
 +
 +struct Lisp_Sub_Char_Table
 +  {
 +    /* HEADER.SIZE is the vector's size field, which also holds the
 +       pseudovector type information.  It holds the size, too.  */
 +    struct vectorlike_header header;
 +
 +    /* Depth of this sub char-table.  It should be 1, 2, or 3.  A sub
 +       char-table of depth 1 contains 16 elements, and each element
 +       covers 4096 (128*32) characters.  A sub char-table of depth 2
 +       contains 32 elements, and each element covers 128 characters.  A
 +       sub char-table of depth 3 contains 128 elements, and each element
 +       is for one character.  */
 +    int depth;
 +
 +    /* Minimum character covered by the sub char-table.  */
 +    int min_char;
 +
 +    /* Use set_sub_char_table_contents to set this.  */
 +    Lisp_Object contents[FLEXIBLE_ARRAY_MEMBER];
 +  };
 +
 +INLINE Lisp_Object
 +CHAR_TABLE_REF_ASCII (Lisp_Object ct, ptrdiff_t idx)
 +{
 +  struct Lisp_Char_Table *tbl = NULL;
 +  Lisp_Object val;
 +  do
 +    {
 +      tbl = tbl ? XCHAR_TABLE (tbl->parent) : XCHAR_TABLE (ct);
 +      val = (! SUB_CHAR_TABLE_P (tbl->ascii) ? tbl->ascii
 +	     : XSUB_CHAR_TABLE (tbl->ascii)->contents[idx]);
 +      if (NILP (val))
 +	val = tbl->defalt;
 +    }
 +  while (NILP (val) && ! NILP (tbl->parent));
 +
 +  return val;
 +}
 +
 +/* Almost equivalent to Faref (CT, IDX) with optimization for ASCII
 +   characters.  Do not check validity of CT.  */
 +INLINE Lisp_Object
 +CHAR_TABLE_REF (Lisp_Object ct, int idx)
 +{
 +  return (ASCII_CHAR_P (idx)
 +	  ? CHAR_TABLE_REF_ASCII (ct, idx)
 +	  : char_table_ref (ct, idx));
 +}
 +
 +/* Equivalent to Faset (CT, IDX, VAL) with optimization for ASCII and
 +   8-bit European characters.  Do not check validity of CT.  */
 +INLINE void
 +CHAR_TABLE_SET (Lisp_Object ct, int idx, Lisp_Object val)
 +{
 +  if (ASCII_CHAR_P (idx) && SUB_CHAR_TABLE_P (XCHAR_TABLE (ct)->ascii))
 +    set_sub_char_table_contents (XCHAR_TABLE (ct)->ascii, idx, val);
 +  else
 +    char_table_set (ct, idx, val);
 +}
 +
 +/* This structure describes a built-in function.
 +   It is generated by the DEFUN macro only.
 +   defsubr makes it into a Lisp object.  */
 +
 +struct Lisp_Subr
 +  {
 +    struct vectorlike_header header;
 +    union {
 +      Lisp_Object (*a0) (void);
 +      Lisp_Object (*a1) (Lisp_Object);
 +      Lisp_Object (*a2) (Lisp_Object, Lisp_Object);
 +      Lisp_Object (*a3) (Lisp_Object, Lisp_Object, Lisp_Object);
 +      Lisp_Object (*a4) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
 +      Lisp_Object (*a5) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
 +      Lisp_Object (*a6) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
 +      Lisp_Object (*a7) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
 +      Lisp_Object (*a8) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
 +      Lisp_Object (*aUNEVALLED) (Lisp_Object args);
 +      Lisp_Object (*aMANY) (ptrdiff_t, Lisp_Object *);
 +    } function;
 +    short min_args, max_args;
 +    const char *symbol_name;
 +    const char *intspec;
 +    const char *doc;
 +  };
 +
 +enum char_table_specials
 +  {
 +    /* This is the number of slots that every char table must have.  This
 +       counts the ordinary slots and the top, defalt, parent, and purpose
 +       slots.  */
 +    CHAR_TABLE_STANDARD_SLOTS = PSEUDOVECSIZE (struct Lisp_Char_Table, extras),
 +
 +    /* This is an index of first Lisp_Object field in Lisp_Sub_Char_Table
 +       when the latter is treated as an ordinary Lisp_Vector.  */
 +    SUB_CHAR_TABLE_OFFSET = PSEUDOVECSIZE (struct Lisp_Sub_Char_Table, contents)
 +  };
 +
 +/* Return the number of "extra" slots in the char table CT.  */
 +
 +INLINE int
 +CHAR_TABLE_EXTRA_SLOTS (struct Lisp_Char_Table *ct)
 +{
 +  return ((ct->header.size & PSEUDOVECTOR_SIZE_MASK)
 +	  - CHAR_TABLE_STANDARD_SLOTS);
 +}
 +
 +/* Make sure that sub char-table contents slot is where we think it is.  */
 +verify (offsetof (struct Lisp_Sub_Char_Table, contents)
 +	== offsetof (struct Lisp_Vector, contents[SUB_CHAR_TABLE_OFFSET]));
 +
 +/***********************************************************************
 +			       Symbols
 + ***********************************************************************/
 +
 +/* Value is name of symbol.  */
 +
 +LISP_MACRO_DEFUN (SYMBOL_VAL, Lisp_Object, (struct Lisp_Symbol *sym), (sym))
 +
 +INLINE struct Lisp_Symbol *
 +SYMBOL_ALIAS (struct Lisp_Symbol *sym)
 +{
 +  eassert (sym->redirect == SYMBOL_VARALIAS);
 +  return sym->val.alias;
 +}
 +INLINE struct Lisp_Buffer_Local_Value *
 +SYMBOL_BLV (struct Lisp_Symbol *sym)
 +{
 +  eassert (sym->redirect == SYMBOL_LOCALIZED);
 +  return sym->val.blv;
 +}
 +INLINE union Lisp_Fwd *
 +SYMBOL_FWD (struct Lisp_Symbol *sym)
 +{
 +  eassert (sym->redirect == SYMBOL_FORWARDED);
 +  return sym->val.fwd;
 +}
 +
 +LISP_MACRO_DEFUN_VOID (SET_SYMBOL_VAL,
 +		       (struct Lisp_Symbol *sym, Lisp_Object v), (sym, v))
 +
 +INLINE void
 +SET_SYMBOL_ALIAS (struct Lisp_Symbol *sym, struct Lisp_Symbol *v)
 +{
 +  eassert (sym->redirect == SYMBOL_VARALIAS);
 +  sym->val.alias = v;
 +}
 +INLINE void
 +SET_SYMBOL_BLV (struct Lisp_Symbol *sym, struct Lisp_Buffer_Local_Value *v)
 +{
 +  eassert (sym->redirect == SYMBOL_LOCALIZED);
 +  sym->val.blv = v;
 +}
 +INLINE void
 +SET_SYMBOL_FWD (struct Lisp_Symbol *sym, union Lisp_Fwd *v)
 +{
 +  eassert (sym->redirect == SYMBOL_FORWARDED);
 +  sym->val.fwd = v;
 +}
 +
 +INLINE Lisp_Object
 +SYMBOL_NAME (Lisp_Object sym)
 +{
 +  return XSYMBOL (sym)->name;
 +}
 +
 +/* Value is true if SYM is an interned symbol.  */
 +
 +INLINE bool
 +SYMBOL_INTERNED_P (Lisp_Object sym)
 +{
 +  return XSYMBOL (sym)->interned != SYMBOL_UNINTERNED;
 +}
 +
 +/* Value is true if SYM is interned in initial_obarray.  */
 +
 +INLINE bool
 +SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (Lisp_Object sym)
 +{
 +  return XSYMBOL (sym)->interned == SYMBOL_INTERNED_IN_INITIAL_OBARRAY;
 +}
 +
 +/* Value is non-zero if symbol is considered a constant, i.e. its
 +   value cannot be changed (there is an exception for keyword symbols,
 +   whose value can be set to the keyword symbol itself).  */
 +
 +LISP_MACRO_DEFUN (SYMBOL_CONSTANT_P, int, (Lisp_Object sym), (sym))
 +
 +/* Placeholder for make-docfile to process.  The actual symbol
 +   definition is done by lread.c's defsym.  */
 +#define DEFSYM(sym, name) /* empty */
 +
 +
 +/***********************************************************************
 +			     Hash Tables
 + ***********************************************************************/
 +
 +/* The structure of a Lisp hash table.  */
 +
 +struct hash_table_test
 +{
 +  /* Name of the function used to compare keys.  */
 +  Lisp_Object name;
 +
 +  /* User-supplied hash function, or nil.  */
 +  Lisp_Object user_hash_function;
 +
 +  /* User-supplied key comparison function, or nil.  */
 +  Lisp_Object user_cmp_function;
 +
 +  /* C function to compare two keys.  */
 +  bool (*cmpfn) (struct hash_table_test *t, Lisp_Object, Lisp_Object);
 +
 +  /* C function to compute hash code.  */
 +  EMACS_UINT (*hashfn) (struct hash_table_test *t, Lisp_Object);
 +};
 +
 +struct Lisp_Hash_Table
 +{
 +  /* This is for Lisp; the hash table code does not refer to it.  */
 +  struct vectorlike_header header;
 +
 +  /* Nil if table is non-weak.  Otherwise a symbol describing the
 +     weakness of the table.  */
 +  Lisp_Object weak;
 +
 +  /* When the table is resized, and this is an integer, compute the
 +     new size by adding this to the old size.  If a float, compute the
 +     new size by multiplying the old size with this factor.  */
 +  Lisp_Object rehash_size;
 +
 +  /* Resize hash table when number of entries/ table size is >= this
 +     ratio, a float.  */
 +  Lisp_Object rehash_threshold;
 +
 +  /* Vector of hash codes.  If hash[I] is nil, this means that the
 +     I-th entry is unused.  */
 +  Lisp_Object hash;
 +
 +  /* Vector used to chain entries.  If entry I is free, next[I] is the
 +     entry number of the next free item.  If entry I is non-free,
 +     next[I] is the index of the next entry in the collision chain.  */
 +  Lisp_Object next;
 +
 +  /* Index of first free entry in free list.  */
 +  Lisp_Object next_free;
 +
 +  /* Bucket vector.  A non-nil entry is the index of the first item in
 +     a collision chain.  This vector's size can be larger than the
 +     hash table size to reduce collisions.  */
 +  Lisp_Object index;
 +
 +  /* Only the fields above are traced normally by the GC.  The ones below
 +     `count' are special and are either ignored by the GC or traced in
 +     a special way (e.g. because of weakness).  */
 +
 +  /* Number of key/value entries in the table.  */
 +  ptrdiff_t count;
 +
 +  /* Vector of keys and values.  The key of item I is found at index
 +     2 * I, the value is found at index 2 * I + 1.
 +     This is gc_marked specially if the table is weak.  */
 +  Lisp_Object key_and_value;
 +
 +  /* The comparison and hash functions.  */
 +  struct hash_table_test test;
 +
 +  /* Next weak hash table if this is a weak hash table.  The head
 +     of the list is in weak_hash_tables.  */
 +  struct Lisp_Hash_Table *next_weak;
 +};
 +
 +
 +INLINE struct Lisp_Hash_Table *
 +XHASH_TABLE (Lisp_Object a)
 +{
 +  return XUNTAG (a, Lisp_Vectorlike);
 +}
 +
 +#define XSET_HASH_TABLE(VAR, PTR) \
 +     (XSETPSEUDOVECTOR (VAR, PTR, PVEC_HASH_TABLE))
 +
 +INLINE bool
 +HASH_TABLE_P (Lisp_Object a)
 +{
 +  return PSEUDOVECTORP (a, PVEC_HASH_TABLE);
 +}
 +
 +/* Value is the key part of entry IDX in hash table H.  */
 +INLINE Lisp_Object
 +HASH_KEY (struct Lisp_Hash_Table *h, ptrdiff_t idx)
 +{
 +  return AREF (h->key_and_value, 2 * idx);
 +}
 +
 +/* Value is the value part of entry IDX in hash table H.  */
 +INLINE Lisp_Object
 +HASH_VALUE (struct Lisp_Hash_Table *h, ptrdiff_t idx)
 +{
 +  return AREF (h->key_and_value, 2 * idx + 1);
 +}
 +
 +/* Value is the index of the next entry following the one at IDX
 +   in hash table H.  */
 +INLINE Lisp_Object
 +HASH_NEXT (struct Lisp_Hash_Table *h, ptrdiff_t idx)
 +{
 +  return AREF (h->next, idx);
 +}
 +
 +/* Value is the hash code computed for entry IDX in hash table H.  */
 +INLINE Lisp_Object
 +HASH_HASH (struct Lisp_Hash_Table *h, ptrdiff_t idx)
 +{
 +  return AREF (h->hash, idx);
 +}
 +
 +/* Value is the index of the element in hash table H that is the
 +   start of the collision list at index IDX in the index vector of H.  */
 +INLINE Lisp_Object
 +HASH_INDEX (struct Lisp_Hash_Table *h, ptrdiff_t idx)
 +{
 +  return AREF (h->index, idx);
 +}
 +
 +/* Value is the size of hash table H.  */
 +INLINE ptrdiff_t
 +HASH_TABLE_SIZE (struct Lisp_Hash_Table *h)
 +{
 +  return ASIZE (h->next);
 +}
 +
 +/* Default size for hash tables if not specified.  */
 +
 +enum DEFAULT_HASH_SIZE { DEFAULT_HASH_SIZE = 65 };
 +
 +/* Default threshold specifying when to resize a hash table.  The
 +   value gives the ratio of current entries in the hash table and the
 +   size of the hash table.  */
 +
 +static double const DEFAULT_REHASH_THRESHOLD = 0.8;
 +
 +/* Default factor by which to increase the size of a hash table.  */
 +
 +static double const DEFAULT_REHASH_SIZE = 1.5;
 +
 +/* Combine two integers X and Y for hashing.  The result might not fit
 +   into a Lisp integer.  */
 +
 +INLINE EMACS_UINT
 +sxhash_combine (EMACS_UINT x, EMACS_UINT y)
 +{
 +  return (x << 4) + (x >> (BITS_PER_EMACS_INT - 4)) + y;
 +}
 +
 +/* Hash X, returning a value that fits into a fixnum.  */
 +
 +INLINE EMACS_UINT
 +SXHASH_REDUCE (EMACS_UINT x)
 +{
 +  return (x ^ x >> (BITS_PER_EMACS_INT - FIXNUM_BITS)) & INTMASK;
 +}
 +
 +/* These structures are used for various misc types.  */
 +
 +struct Lisp_Misc_Any		/* Supertype of all Misc types.  */
 +{
 +  ENUM_BF (Lisp_Misc_Type) type : 16;		/* = Lisp_Misc_??? */
 +  bool_bf gcmarkbit : 1;
 +  unsigned spacer : 15;
 +};
 +
 +struct Lisp_Marker
 +{
 +  ENUM_BF (Lisp_Misc_Type) type : 16;		/* = Lisp_Misc_Marker */
 +  bool_bf gcmarkbit : 1;
 +  unsigned spacer : 13;
 +  /* This flag is temporarily used in the functions
 +     decode/encode_coding_object to record that the marker position
 +     must be adjusted after the conversion.  */
 +  bool_bf need_adjustment : 1;
 +  /* True means normal insertion at the marker's position
 +     leaves the marker after the inserted text.  */
 +  bool_bf insertion_type : 1;
 +  /* This is the buffer that the marker points into, or 0 if it points nowhere.
 +     Note: a chain of markers can contain markers pointing into different
 +     buffers (the chain is per buffer_text rather than per buffer, so it's
 +     shared between indirect buffers).  */
 +  /* This is used for (other than NULL-checking):
 +     - Fmarker_buffer
 +     - Fset_marker: check eq(oldbuf, newbuf) to avoid unchain+rechain.
 +     - unchain_marker: to find the list from which to unchain.
 +     - Fkill_buffer: to only unchain the markers of current indirect buffer.
 +     */
 +  struct buffer *buffer;
 +
 +  /* The remaining fields are meaningless in a marker that
 +     does not point anywhere.  */
 +
 +  /* For markers that point somewhere,
 +     this is used to chain of all the markers in a given buffer.  */
 +  /* We could remove it and use an array in buffer_text instead.
 +     That would also allow us to preserve it ordered.  */
 +  struct Lisp_Marker *next;
 +  /* This is the char position where the marker points.  */
 +  ptrdiff_t charpos;
 +  /* This is the byte position.
 +     It's mostly used as a charpos<->bytepos cache (i.e. it's not directly
 +     used to implement the functionality of markers, but rather to (ab)use
 +     markers as a cache for char<->byte mappings).  */
 +  ptrdiff_t bytepos;
 +};
 +
 +/* START and END are markers in the overlay's buffer, and
 +   PLIST is the overlay's property list.  */
 +struct Lisp_Overlay
 +/* An overlay's real data content is:
 +   - plist
 +   - buffer (really there are two buffer pointers, one per marker,
 +     and both points to the same buffer)
 +   - insertion type of both ends (per-marker fields)
 +   - start & start byte (of start marker)
 +   - end & end byte (of end marker)
 +   - next (singly linked list of overlays)
 +   - next fields of start and end markers (singly linked list of markers).
 +   I.e. 9words plus 2 bits, 3words of which are for external linked lists.
 +*/
 +  {
 +    ENUM_BF (Lisp_Misc_Type) type : 16;	/* = Lisp_Misc_Overlay */
 +    bool_bf gcmarkbit : 1;
 +    unsigned spacer : 15;
 +    struct Lisp_Overlay *next;
 +    Lisp_Object start;
 +    Lisp_Object end;
 +    Lisp_Object plist;
 +  };
 +
 +/* Types of data which may be saved in a Lisp_Save_Value.  */
 +
 +enum
 +  {
 +    SAVE_UNUSED,
 +    SAVE_INTEGER,
 +    SAVE_FUNCPOINTER,
 +    SAVE_POINTER,
 +    SAVE_OBJECT
 +  };
 +
 +/* Number of bits needed to store one of the above values.  */
 +enum { SAVE_SLOT_BITS = 3 };
 +
 +/* Number of slots in a save value where save_type is nonzero.  */
 +enum { SAVE_VALUE_SLOTS = 4 };
 +
 +/* Bit-width and values for struct Lisp_Save_Value's save_type member.  */
 +
 +enum { SAVE_TYPE_BITS = SAVE_VALUE_SLOTS * SAVE_SLOT_BITS + 1 };
 +
 +enum Lisp_Save_Type
 +  {
 +    SAVE_TYPE_INT_INT = SAVE_INTEGER + (SAVE_INTEGER << SAVE_SLOT_BITS),
 +    SAVE_TYPE_INT_INT_INT
 +      = (SAVE_INTEGER + (SAVE_TYPE_INT_INT << SAVE_SLOT_BITS)),
 +    SAVE_TYPE_OBJ_OBJ = SAVE_OBJECT + (SAVE_OBJECT << SAVE_SLOT_BITS),
 +    SAVE_TYPE_OBJ_OBJ_OBJ = SAVE_OBJECT + (SAVE_TYPE_OBJ_OBJ << SAVE_SLOT_BITS),
 +    SAVE_TYPE_OBJ_OBJ_OBJ_OBJ
 +      = SAVE_OBJECT + (SAVE_TYPE_OBJ_OBJ_OBJ << SAVE_SLOT_BITS),
 +    SAVE_TYPE_PTR_INT = SAVE_POINTER + (SAVE_INTEGER << SAVE_SLOT_BITS),
 +    SAVE_TYPE_PTR_OBJ = SAVE_POINTER + (SAVE_OBJECT << SAVE_SLOT_BITS),
 +    SAVE_TYPE_PTR_PTR = SAVE_POINTER + (SAVE_POINTER << SAVE_SLOT_BITS),
 +    SAVE_TYPE_FUNCPTR_PTR_OBJ
 +      = SAVE_FUNCPOINTER + (SAVE_TYPE_PTR_OBJ << SAVE_SLOT_BITS),
 +
 +    /* This has an extra bit indicating it's raw memory.  */
 +    SAVE_TYPE_MEMORY = SAVE_TYPE_PTR_INT + (1 << (SAVE_TYPE_BITS - 1))
 +  };
 +
 +/* Special object used to hold a different values for later use.
 +
 +   This is mostly used to package C integers and pointers to call
 +   record_unwind_protect when two or more values need to be saved.
 +   For example:
 +
 +   ...
 +     struct my_data *md = get_my_data ();
 +     ptrdiff_t mi = get_my_integer ();
 +     record_unwind_protect (my_unwind, make_save_ptr_int (md, mi));
 +   ...
 +
 +   Lisp_Object my_unwind (Lisp_Object arg)
 +   {
 +     struct my_data *md = XSAVE_POINTER (arg, 0);
 +     ptrdiff_t mi = XSAVE_INTEGER (arg, 1);
 +     ...
 +   }
 +
 +   If ENABLE_CHECKING is in effect, XSAVE_xxx macros do type checking of the
 +   saved objects and raise eassert if type of the saved object doesn't match
 +   the type which is extracted.  In the example above, XSAVE_INTEGER (arg, 2)
 +   and XSAVE_OBJECT (arg, 0) are wrong because nothing was saved in slot 2 and
 +   slot 0 is a pointer.  */
 +
 +typedef void (*voidfuncptr) (void);
 +
 +struct Lisp_Save_Value
 +  {
 +    ENUM_BF (Lisp_Misc_Type) type : 16;	/* = Lisp_Misc_Save_Value */
 +    bool_bf gcmarkbit : 1;
 +    unsigned spacer : 32 - (16 + 1 + SAVE_TYPE_BITS);
 +
 +    /* V->data may hold up to SAVE_VALUE_SLOTS entries.  The type of
 +       V's data entries are determined by V->save_type.  E.g., if
 +       V->save_type == SAVE_TYPE_PTR_OBJ, V->data[0] is a pointer,
 +       V->data[1] is an integer, and V's other data entries are unused.
 +
 +       If V->save_type == SAVE_TYPE_MEMORY, V->data[0].pointer is the address of
 +       a memory area containing V->data[1].integer potential Lisp_Objects.  */
 +    ENUM_BF (Lisp_Save_Type) save_type : SAVE_TYPE_BITS;
 +    union {
 +      void *pointer;
 +      voidfuncptr funcpointer;
 +      ptrdiff_t integer;
 +      Lisp_Object object;
 +    } data[SAVE_VALUE_SLOTS];
 +  };
 +
 +/* Return the type of V's Nth saved value.  */
 +INLINE int
 +save_type (struct Lisp_Save_Value *v, int n)
 +{
 +  eassert (0 <= n && n < SAVE_VALUE_SLOTS);
 +  return (v->save_type >> (SAVE_SLOT_BITS * n) & ((1 << SAVE_SLOT_BITS) - 1));
 +}
 +
 +/* Get and set the Nth saved pointer.  */
 +
 +INLINE void *
 +XSAVE_POINTER (Lisp_Object obj, int n)
 +{
 +  eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_POINTER);
 +  return XSAVE_VALUE (obj)->data[n].pointer;
 +}
 +INLINE void
 +set_save_pointer (Lisp_Object obj, int n, void *val)
 +{
 +  eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_POINTER);
 +  XSAVE_VALUE (obj)->data[n].pointer = val;
 +}
 +INLINE voidfuncptr
 +XSAVE_FUNCPOINTER (Lisp_Object obj, int n)
 +{
 +  eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_FUNCPOINTER);
 +  return XSAVE_VALUE (obj)->data[n].funcpointer;
 +}
 +
 +/* Likewise for the saved integer.  */
 +
 +INLINE ptrdiff_t
 +XSAVE_INTEGER (Lisp_Object obj, int n)
 +{
 +  eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_INTEGER);
 +  return XSAVE_VALUE (obj)->data[n].integer;
 +}
 +INLINE void
 +set_save_integer (Lisp_Object obj, int n, ptrdiff_t val)
 +{
 +  eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_INTEGER);
 +  XSAVE_VALUE (obj)->data[n].integer = val;
 +}
 +
 +/* Extract Nth saved object.  */
 +
 +INLINE Lisp_Object
 +XSAVE_OBJECT (Lisp_Object obj, int n)
 +{
 +  eassert (save_type (XSAVE_VALUE (obj), n) == SAVE_OBJECT);
 +  return XSAVE_VALUE (obj)->data[n].object;
 +}
 +
 +/* A finalizer sentinel.  */
 +struct Lisp_Finalizer
 +  {
 +    struct Lisp_Misc_Any base;
 +
 +    /* Circular list of all active weak references.  */
 +    struct Lisp_Finalizer *prev;
 +    struct Lisp_Finalizer *next;
 +
 +    /* Call FUNCTION when the finalizer becomes unreachable, even if
 +       FUNCTION contains a reference to the finalizer; i.e., call
 +       FUNCTION when it is reachable _only_ through finalizers.  */
 +    Lisp_Object function;
 +  };
 +
 +/* A miscellaneous object, when it's on the free list.  */
 +struct Lisp_Free
 +  {
 +    ENUM_BF (Lisp_Misc_Type) type : 16;	/* = Lisp_Misc_Free */
 +    bool_bf gcmarkbit : 1;
 +    unsigned spacer : 15;
 +    union Lisp_Misc *chain;
 +  };
 +
 +/* To get the type field of a union Lisp_Misc, use XMISCTYPE.
 +   It uses one of these struct subtypes to get the type field.  */
 +
 +union Lisp_Misc
 +  {
 +    struct Lisp_Misc_Any u_any;	   /* Supertype of all Misc types.  */
 +    struct Lisp_Free u_free;
 +    struct Lisp_Marker u_marker;
 +    struct Lisp_Overlay u_overlay;
 +    struct Lisp_Save_Value u_save_value;
 +    struct Lisp_Finalizer u_finalizer;
 +  };
 +
 +INLINE union Lisp_Misc *
 +XMISC (Lisp_Object a)
 +{
 +  return XUNTAG (a, Lisp_Misc);
 +}
 +
 +INLINE struct Lisp_Misc_Any *
 +XMISCANY (Lisp_Object a)
 +{
 +  eassert (MISCP (a));
 +  return & XMISC (a)->u_any;
 +}
 +
 +INLINE enum Lisp_Misc_Type
 +XMISCTYPE (Lisp_Object a)
 +{
 +  return XMISCANY (a)->type;
 +}
 +
 +INLINE struct Lisp_Marker *
 +XMARKER (Lisp_Object a)
 +{
 +  eassert (MARKERP (a));
 +  return & XMISC (a)->u_marker;
 +}
 +
 +INLINE struct Lisp_Overlay *
 +XOVERLAY (Lisp_Object a)
 +{
 +  eassert (OVERLAYP (a));
 +  return & XMISC (a)->u_overlay;
 +}
 +
 +INLINE struct Lisp_Save_Value *
 +XSAVE_VALUE (Lisp_Object a)
 +{
 +  eassert (SAVE_VALUEP (a));
 +  return & XMISC (a)->u_save_value;
 +}
 +
 +INLINE struct Lisp_Finalizer *
 +XFINALIZER (Lisp_Object a)
 +{
 +  eassert (FINALIZERP (a));
 +  return & XMISC (a)->u_finalizer;
 +}
 +
 +
 +/* Forwarding pointer to an int variable.
 +   This is allowed only in the value cell of a symbol,
 +   and it means that the symbol's value really lives in the
 +   specified int variable.  */
 +struct Lisp_Intfwd
 +  {
 +    enum Lisp_Fwd_Type type;	/* = Lisp_Fwd_Int */
 +    EMACS_INT *intvar;
 +  };
 +
 +/* Boolean forwarding pointer to an int variable.
 +   This is like Lisp_Intfwd except that the ostensible
 +   "value" of the symbol is t if the bool variable is true,
 +   nil if it is false.  */
 +struct Lisp_Boolfwd
 +  {
 +    enum Lisp_Fwd_Type type;	/* = Lisp_Fwd_Bool */
 +    bool *boolvar;
 +  };
 +
 +/* Forwarding pointer to a Lisp_Object variable.
 +   This is allowed only in the value cell of a symbol,
 +   and it means that the symbol's value really lives in the
 +   specified variable.  */
 +struct Lisp_Objfwd
 +  {
 +    enum Lisp_Fwd_Type type;	/* = Lisp_Fwd_Obj */
 +    Lisp_Object *objvar;
 +  };
 +
 +/* Like Lisp_Objfwd except that value lives in a slot in the
 +   current buffer.  Value is byte index of slot within buffer.  */
 +struct Lisp_Buffer_Objfwd
 +  {
 +    enum Lisp_Fwd_Type type;	/* = Lisp_Fwd_Buffer_Obj */
 +    int offset;
 +    /* One of Qnil, Qintegerp, Qsymbolp, Qstringp, Qfloatp or Qnumberp.  */
 +    Lisp_Object predicate;
 +  };
 +
 +/* struct Lisp_Buffer_Local_Value is used in a symbol value cell when
 +   the symbol has buffer-local or frame-local bindings.  (Exception:
 +   some buffer-local variables are built-in, with their values stored
 +   in the buffer structure itself.  They are handled differently,
 +   using struct Lisp_Buffer_Objfwd.)
 +
 +   The `realvalue' slot holds the variable's current value, or a
 +   forwarding pointer to where that value is kept.  This value is the
 +   one that corresponds to the loaded binding.  To read or set the
 +   variable, you must first make sure the right binding is loaded;
 +   then you can access the value in (or through) `realvalue'.
 +
 +   `buffer' and `frame' are the buffer and frame for which the loaded
 +   binding was found.  If those have changed, to make sure the right
 +   binding is loaded it is necessary to find which binding goes with
 +   the current buffer and selected frame, then load it.  To load it,
 +   first unload the previous binding, then copy the value of the new
 +   binding into `realvalue' (or through it).  Also update
 +   LOADED-BINDING to point to the newly loaded binding.
 +
 +   `local_if_set' indicates that merely setting the variable creates a
 +   local binding for the current buffer.  Otherwise the latter, setting
 +   the variable does not do that; only make-local-variable does that.  */
 +
 +struct Lisp_Buffer_Local_Value
 +  {
 +    /* True means that merely setting the variable creates a local
 +       binding for the current buffer.  */
 +    bool_bf local_if_set : 1;
 +    /* True means this variable can have frame-local bindings, otherwise, it is
 +       can have buffer-local bindings.  The two cannot be combined.  */
 +    bool_bf frame_local : 1;
 +    /* True means that the binding now loaded was found.
 +       Presumably equivalent to (defcell!=valcell).  */
 +    bool_bf found : 1;
 +    /* If non-NULL, a forwarding to the C var where it should also be set.  */
 +    union Lisp_Fwd *fwd;	/* Should never be (Buffer|Kboard)_Objfwd.  */
 +    /* The buffer or frame for which the loaded binding was found.  */
 +    Lisp_Object where;
 +    /* A cons cell that holds the default value.  It has the form
 +       (SYMBOL . DEFAULT-VALUE).  */
 +    Lisp_Object defcell;
 +    /* The cons cell from `where's parameter alist.
 +       It always has the form (SYMBOL . VALUE)
 +       Note that if `forward' is non-nil, VALUE may be out of date.
 +       Also if the currently loaded binding is the default binding, then
 +       this is `eq'ual to defcell.  */
 +    Lisp_Object valcell;
 +  };
 +
 +/* Like Lisp_Objfwd except that value lives in a slot in the
 +   current kboard.  */
 +struct Lisp_Kboard_Objfwd
 +  {
 +    enum Lisp_Fwd_Type type;	/* = Lisp_Fwd_Kboard_Obj */
 +    int offset;
 +  };
 +
 +union Lisp_Fwd
 +  {
 +    struct Lisp_Intfwd u_intfwd;
 +    struct Lisp_Boolfwd u_boolfwd;
 +    struct Lisp_Objfwd u_objfwd;
 +    struct Lisp_Buffer_Objfwd u_buffer_objfwd;
 +    struct Lisp_Kboard_Objfwd u_kboard_objfwd;
 +  };
 +
 +INLINE enum Lisp_Fwd_Type
 +XFWDTYPE (union Lisp_Fwd *a)
 +{
 +  return a->u_intfwd.type;
 +}
 +
 +INLINE struct Lisp_Buffer_Objfwd *
 +XBUFFER_OBJFWD (union Lisp_Fwd *a)
 +{
 +  eassert (BUFFER_OBJFWDP (a));
 +  return &a->u_buffer_objfwd;
 +}
 +
 +/* Lisp floating point type.  */
 +struct Lisp_Float
 +  {
 +    union
 +    {
 +      double data;
 +      struct Lisp_Float *chain;
 +    } u;
 +  };
 +
 +INLINE double
 +XFLOAT_DATA (Lisp_Object f)
 +{
 +  return XFLOAT (f)->u.data;
 +}
 +
 +/* Most hosts nowadays use IEEE floating point, so they use IEC 60559
 +   representations, have infinities and NaNs, and do not trap on
 +   exceptions.  Define IEEE_FLOATING_POINT if this host is one of the
 +   typical ones.  The C11 macro __STDC_IEC_559__ is close to what is
 +   wanted here, but is not quite right because Emacs does not require
 +   all the features of C11 Annex F (and does not require C11 at all,
 +   for that matter).  */
 +enum
 +  {
 +    IEEE_FLOATING_POINT
 +      = (FLT_RADIX == 2 && FLT_MANT_DIG == 24
 +	 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
 +  };
 +
 +/* A character, declared with the following typedef, is a member
 +   of some character set associated with the current buffer.  */
 +#ifndef _UCHAR_T  /* Protect against something in ctab.h on AIX.  */
 +#define _UCHAR_T
 +typedef unsigned char UCHAR;
 +#endif
 +
 +/* Meanings of slots in a Lisp_Compiled:  */
 +
 +enum Lisp_Compiled
 +  {
 +    COMPILED_ARGLIST = 0,
 +    COMPILED_BYTECODE = 1,
 +    COMPILED_CONSTANTS = 2,
 +    COMPILED_STACK_DEPTH = 3,
 +    COMPILED_DOC_STRING = 4,
 +    COMPILED_INTERACTIVE = 5
 +  };
 +
 +/* Flag bits in a character.  These also get used in termhooks.h.
 +   Richard Stallman  thinks that MULE
 +   (MUlti-Lingual Emacs) might need 22 bits for the character value
 +   itself, so we probably shouldn't use any bits lower than 0x0400000.  */
 +enum char_bits
 +  {
 +    CHAR_ALT = 0x0400000,
 +    CHAR_SUPER = 0x0800000,
 +    CHAR_HYPER = 0x1000000,
 +    CHAR_SHIFT = 0x2000000,
 +    CHAR_CTL = 0x4000000,
 +    CHAR_META = 0x8000000,
 +
 +    CHAR_MODIFIER_MASK =
 +      CHAR_ALT | CHAR_SUPER | CHAR_HYPER | CHAR_SHIFT | CHAR_CTL | CHAR_META,
 +
 +    /* Actually, the current Emacs uses 22 bits for the character value
 +       itself.  */
 +    CHARACTERBITS = 22
 +  };
 +
 +/* Data type checking.  */
 +
 +LISP_MACRO_DEFUN (NILP, bool, (Lisp_Object x), (x))
 +
 +INLINE bool
 +NUMBERP (Lisp_Object x)
 +{
 +  return INTEGERP (x) || FLOATP (x);
 +}
 +INLINE bool
 +NATNUMP (Lisp_Object x)
 +{
 +  return INTEGERP (x) && 0 <= XINT (x);
 +}
 +
 +INLINE bool
 +RANGED_INTEGERP (intmax_t lo, Lisp_Object x, intmax_t hi)
 +{
 +  return INTEGERP (x) && lo <= XINT (x) && XINT (x) <= hi;
 +}
 +
 +#define TYPE_RANGED_INTEGERP(type, x) \
 +  (INTEGERP (x)			      \
 +   && (TYPE_SIGNED (type) ? TYPE_MINIMUM (type) <= XINT (x) : 0 <= XINT (x)) \
 +   && XINT (x) <= TYPE_MAXIMUM (type))
 +
 +LISP_MACRO_DEFUN (CONSP, bool, (Lisp_Object x), (x))
 +LISP_MACRO_DEFUN (FLOATP, bool, (Lisp_Object x), (x))
 +LISP_MACRO_DEFUN (MISCP, bool, (Lisp_Object x), (x))
 +LISP_MACRO_DEFUN (SYMBOLP, bool, (Lisp_Object x), (x))
 +LISP_MACRO_DEFUN (INTEGERP, bool, (Lisp_Object x), (x))
 +LISP_MACRO_DEFUN (VECTORLIKEP, bool, (Lisp_Object x), (x))
 +LISP_MACRO_DEFUN (MARKERP, bool, (Lisp_Object x), (x))
 +
 +INLINE bool
 +STRINGP (Lisp_Object x)
 +{
 +  return XTYPE (x) == Lisp_String;
 +}
 +INLINE bool
 +VECTORP (Lisp_Object x)
 +{
 +  return VECTORLIKEP (x) && ! (ASIZE (x) & PSEUDOVECTOR_FLAG);
 +}
 +INLINE bool
 +OVERLAYP (Lisp_Object x)
 +{
 +  return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Overlay;
 +}
 +INLINE bool
 +SAVE_VALUEP (Lisp_Object x)
 +{
 +  return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Save_Value;
 +}
 +
 +INLINE bool
 +FINALIZERP (Lisp_Object x)
 +{
 +  return MISCP (x) && XMISCTYPE (x) == Lisp_Misc_Finalizer;
 +}
 +
 +INLINE bool
 +AUTOLOADP (Lisp_Object x)
 +{
 +  return CONSP (x) && EQ (Qautoload, XCAR (x));
 +}
 +
 +INLINE bool
 +BUFFER_OBJFWDP (union Lisp_Fwd *a)
 +{
 +  return XFWDTYPE (a) == Lisp_Fwd_Buffer_Obj;
 +}
 +
 +INLINE bool
 +PSEUDOVECTOR_TYPEP (struct vectorlike_header *a, int code)
 +{
 +  return ((a->size & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK))
 +	  == (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS)));
 +}
 +
 +/* True if A is a pseudovector whose code is CODE.  */
 +INLINE bool
 +PSEUDOVECTORP (Lisp_Object a, int code)
 +{
 +  if (! VECTORLIKEP (a))
 +    return false;
 +  else
 +    {
 +      /* Converting to struct vectorlike_header * avoids aliasing issues.  */
 +      struct vectorlike_header *h = XUNTAG (a, Lisp_Vectorlike);
 +      return PSEUDOVECTOR_TYPEP (h, code);
 +    }
 +}
 +
 +
 +/* Test for specific pseudovector types.  */
 +
 +INLINE bool
 +WINDOW_CONFIGURATIONP (Lisp_Object a)
 +{
 +  return PSEUDOVECTORP (a, PVEC_WINDOW_CONFIGURATION);
 +}
 +
 +INLINE bool
 +PROCESSP (Lisp_Object a)
 +{
 +  return PSEUDOVECTORP (a, PVEC_PROCESS);
 +}
 +
 +INLINE bool
 +WINDOWP (Lisp_Object a)
 +{
 +  return PSEUDOVECTORP (a, PVEC_WINDOW);
 +}
 +
 +INLINE bool
 +TERMINALP (Lisp_Object a)
 +{
 +  return PSEUDOVECTORP (a, PVEC_TERMINAL);
 +}
 +
 +INLINE bool
 +SUBRP (Lisp_Object a)
 +{
 +  return PSEUDOVECTORP (a, PVEC_SUBR);
 +}
 +
 +INLINE bool
 +COMPILEDP (Lisp_Object a)
 +{
 +  return PSEUDOVECTORP (a, PVEC_COMPILED);
 +}
 +
 +INLINE bool
 +BUFFERP (Lisp_Object a)
 +{
 +  return PSEUDOVECTORP (a, PVEC_BUFFER);
 +}
 +
 +INLINE bool
 +CHAR_TABLE_P (Lisp_Object a)
 +{
 +  return PSEUDOVECTORP (a, PVEC_CHAR_TABLE);
 +}
 +
 +INLINE bool
 +SUB_CHAR_TABLE_P (Lisp_Object a)
 +{
 +  return PSEUDOVECTORP (a, PVEC_SUB_CHAR_TABLE);
 +}
 +
 +INLINE bool
 +BOOL_VECTOR_P (Lisp_Object a)
 +{
 +  return PSEUDOVECTORP (a, PVEC_BOOL_VECTOR);
 +}
 +
 +INLINE bool
 +FRAMEP (Lisp_Object a)
 +{
 +  return PSEUDOVECTORP (a, PVEC_FRAME);
 +}
 +
 +/* Test for image (image . spec)  */
 +INLINE bool
 +IMAGEP (Lisp_Object x)
 +{
 +  return CONSP (x) && EQ (XCAR (x), Qimage);
 +}
 +
 +/* Array types.  */
 +INLINE bool
 +ARRAYP (Lisp_Object x)
 +{
 +  return VECTORP (x) || STRINGP (x) || CHAR_TABLE_P (x) || BOOL_VECTOR_P (x);
 +}
 +
 +INLINE void
 +CHECK_LIST (Lisp_Object x)
 +{
 +  CHECK_TYPE (CONSP (x) || NILP (x), Qlistp, x);
 +}
 +
 +LISP_MACRO_DEFUN_VOID (CHECK_LIST_CONS, (Lisp_Object x, Lisp_Object y), (x, y))
 +LISP_MACRO_DEFUN_VOID (CHECK_SYMBOL, (Lisp_Object x), (x))
 +LISP_MACRO_DEFUN_VOID (CHECK_NUMBER, (Lisp_Object x), (x))
 +
 +INLINE void
 +CHECK_STRING (Lisp_Object x)
 +{
 +  CHECK_TYPE (STRINGP (x), Qstringp, x);
 +}
 +INLINE void
 +CHECK_STRING_CAR (Lisp_Object x)
 +{
 +  CHECK_TYPE (STRINGP (XCAR (x)), Qstringp, XCAR (x));
 +}
 +INLINE void
 +CHECK_CONS (Lisp_Object x)
 +{
 +  CHECK_TYPE (CONSP (x), Qconsp, x);
 +}
 +INLINE void
 +CHECK_VECTOR (Lisp_Object x)
 +{
 +  CHECK_TYPE (VECTORP (x), Qvectorp, x);
 +}
 +INLINE void
 +CHECK_BOOL_VECTOR (Lisp_Object x)
 +{
 +  CHECK_TYPE (BOOL_VECTOR_P (x), Qbool_vector_p, x);
 +}
 +/* This is a bit special because we always need size afterwards.  */
 +INLINE ptrdiff_t
 +CHECK_VECTOR_OR_STRING (Lisp_Object x)
 +{
 +  if (VECTORP (x))
 +    return ASIZE (x);
 +  if (STRINGP (x))
 +    return SCHARS (x);
 +  wrong_type_argument (Qarrayp, x);
 +}
 +INLINE void
 +CHECK_ARRAY (Lisp_Object x, Lisp_Object predicate)
 +{
 +  CHECK_TYPE (ARRAYP (x), predicate, x);
 +}
 +INLINE void
 +CHECK_BUFFER (Lisp_Object x)
 +{
 +  CHECK_TYPE (BUFFERP (x), Qbufferp, x);
 +}
 +INLINE void
 +CHECK_WINDOW (Lisp_Object x)
 +{
 +  CHECK_TYPE (WINDOWP (x), Qwindowp, x);
 +}
 +#ifdef subprocesses
 +INLINE void
 +CHECK_PROCESS (Lisp_Object x)
 +{
 +  CHECK_TYPE (PROCESSP (x), Qprocessp, x);
 +}
 +#endif
 +INLINE void
 +CHECK_NATNUM (Lisp_Object x)
 +{
 +  CHECK_TYPE (NATNUMP (x), Qwholenump, x);
 +}
 +
 +#define CHECK_RANGED_INTEGER(x, lo, hi)					\
 +  do {									\
 +    CHECK_NUMBER (x);							\
 +    if (! ((lo) <= XINT (x) && XINT (x) <= (hi)))			\
 +      args_out_of_range_3						\
 +	(x,								\
 +	 make_number ((lo) < 0 && (lo) < MOST_NEGATIVE_FIXNUM		\
 +		      ? MOST_NEGATIVE_FIXNUM				\
 +		      : (lo)),						\
 +	 make_number (min (hi, MOST_POSITIVE_FIXNUM)));			\
 +  } while (false)
 +#define CHECK_TYPE_RANGED_INTEGER(type, x) \
 +  do {									\
 +    if (TYPE_SIGNED (type))						\
 +      CHECK_RANGED_INTEGER (x, TYPE_MINIMUM (type), TYPE_MAXIMUM (type)); \
 +    else								\
 +      CHECK_RANGED_INTEGER (x, 0, TYPE_MAXIMUM (type));			\
 +  } while (false)
 +
 +#define CHECK_NUMBER_COERCE_MARKER(x)					\
 +  do {									\
 +    if (MARKERP ((x)))							\
 +      XSETFASTINT (x, marker_position (x));				\
 +    else								\
 +      CHECK_TYPE (INTEGERP (x), Qinteger_or_marker_p, x);		\
 +  } while (false)
 +
 +INLINE double
 +XFLOATINT (Lisp_Object n)
 +{
 +  return extract_float (n);
 +}
 +
 +INLINE void
 +CHECK_NUMBER_OR_FLOAT (Lisp_Object x)
 +{
 +  CHECK_TYPE (FLOATP (x) || INTEGERP (x), Qnumberp, x);
 +}
 +
 +#define CHECK_NUMBER_OR_FLOAT_COERCE_MARKER(x)				\
 +  do {									\
 +    if (MARKERP (x))							\
 +      XSETFASTINT (x, marker_position (x));				\
 +    else								\
 +      CHECK_TYPE (INTEGERP (x) || FLOATP (x), Qnumber_or_marker_p, x);	\
 +  } while (false)
 +
 +/* Since we can't assign directly to the CAR or CDR fields of a cons
 +   cell, use these when checking that those fields contain numbers.  */
 +INLINE void
 +CHECK_NUMBER_CAR (Lisp_Object x)
 +{
 +  Lisp_Object tmp = XCAR (x);
 +  CHECK_NUMBER (tmp);
 +  XSETCAR (x, tmp);
 +}
 +
 +INLINE void
 +CHECK_NUMBER_CDR (Lisp_Object x)
 +{
 +  Lisp_Object tmp = XCDR (x);
 +  CHECK_NUMBER (tmp);
 +  XSETCDR (x, tmp);
 +}
 +
 +/* Define a built-in function for calling from Lisp.
 + `lname' should be the name to give the function in Lisp,
 +    as a null-terminated C string.
 + `fnname' should be the name of the function in C.
 +    By convention, it starts with F.
 + `sname' should be the name for the C constant structure
 +    that records information on this function for internal use.
 +    By convention, it should be the same as `fnname' but with S instead of F.
 +    It's too bad that C macros can't compute this from `fnname'.
 + `minargs' should be a number, the minimum number of arguments allowed.
 + `maxargs' should be a number, the maximum number of arguments allowed,
 +    or else MANY or UNEVALLED.
 +    MANY means pass a vector of evaluated arguments,
 +	 in the form of an integer number-of-arguments
 +	 followed by the address of a vector of Lisp_Objects
 +	 which contains the argument values.
 +    UNEVALLED means pass the list of unevaluated arguments
 + `intspec' says how interactive arguments are to be fetched.
 +    If the string starts with a `(', `intspec' is evaluated and the resulting
 +    list is the list of arguments.
 +    If it's a string that doesn't start with `(', the value should follow
 +    the one of the doc string for `interactive'.
 +    A null string means call interactively with no arguments.
 + `doc' is documentation for the user.  */
 +
 +/* This version of DEFUN declares a function prototype with the right
 +   arguments, so we can catch errors with maxargs at compile-time.  */
 +#ifdef _MSC_VER
 +#define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc)	\
 +   Lisp_Object fnname DEFUN_ARGS_ ## maxargs ;				\
 +   static struct Lisp_Subr alignas (GCALIGNMENT) sname =		\
 +   { { (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS)				\
 +       | (sizeof (struct Lisp_Subr) / sizeof (EMACS_INT)) },		\
 +      { (Lisp_Object (__cdecl *)(void))fnname },                        \
 +       minargs, maxargs, lname, intspec, 0};				\
 +   Lisp_Object fnname
 +#else  /* not _MSC_VER */
 +#define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc)	\
 +   static struct Lisp_Subr alignas (GCALIGNMENT) sname =		\
 +     { { PVEC_SUBR << PSEUDOVECTOR_AREA_BITS },				\
 +       { .a ## maxargs = fnname },					\
 +       minargs, maxargs, lname, intspec, 0};				\
 +   Lisp_Object fnname
 +#endif
 +
 +/* True if OBJ is a Lisp function.  */
 +INLINE bool
 +FUNCTIONP (Lisp_Object obj)
 +{
 +  return functionp (obj);
 +}
 +
 +/* defsubr (Sname);
 +   is how we define the symbol for function `name' at start-up time.  */
 +extern void defsubr (struct Lisp_Subr *);
 +
 +enum maxargs
 +  {
 +    MANY = -2,
 +    UNEVALLED = -1
 +  };
 +
 +/* Call a function F that accepts many args, passing it ARRAY's elements.  */
 +#define CALLMANY(f, array) (f) (ARRAYELTS (array), array)
 +
 +/* Call a function F that accepts many args, passing it the remaining args,
 +   E.g., 'return CALLN (Fformat, fmt, text);' is less error-prone than
 +   '{ Lisp_Object a[2]; a[0] = fmt; a[1] = text; return Fformat (2, a); }'.
 +   CALLN is overkill for simple usages like 'Finsert (1, &text);'.  */
 +#define CALLN(f, ...) CALLMANY (f, ((Lisp_Object []) {__VA_ARGS__}))
 +
 +extern void defvar_lisp (struct Lisp_Objfwd *, const char *, Lisp_Object *);
 +extern void defvar_lisp_nopro (struct Lisp_Objfwd *, const char *, Lisp_Object *);
 +extern void defvar_bool (struct Lisp_Boolfwd *, const char *, bool *);
 +extern void defvar_int (struct Lisp_Intfwd *, const char *, EMACS_INT *);
 +extern void defvar_kboard (struct Lisp_Kboard_Objfwd *, const char *, int);
 +
 +/* Macros we use to define forwarded Lisp variables.
 +   These are used in the syms_of_FILENAME functions.
 +
 +   An ordinary (not in buffer_defaults, per-buffer, or per-keyboard)
 +   lisp variable is actually a field in `struct emacs_globals'.  The
 +   field's name begins with "f_", which is a convention enforced by
 +   these macros.  Each such global has a corresponding #define in
 +   globals.h; the plain name should be used in the code.
 +
 +   E.g., the global "cons_cells_consed" is declared as "int
 +   f_cons_cells_consed" in globals.h, but there is a define:
 +
 +      #define cons_cells_consed globals.f_cons_cells_consed
 +
 +   All C code uses the `cons_cells_consed' name.  This is all done
 +   this way to support indirection for multi-threaded Emacs.  */
 +
 +#define DEFVAR_LISP(lname, vname, doc)		\
 +  do {						\
 +    static struct Lisp_Objfwd o_fwd;		\
 +    defvar_lisp (&o_fwd, lname, &globals.f_ ## vname);		\
 +  } while (false)
 +#define DEFVAR_LISP_NOPRO(lname, vname, doc)	\
 +  do {						\
 +    static struct Lisp_Objfwd o_fwd;		\
 +    defvar_lisp_nopro (&o_fwd, lname, &globals.f_ ## vname);	\
 +  } while (false)
 +#define DEFVAR_BOOL(lname, vname, doc)		\
 +  do {						\
 +    static struct Lisp_Boolfwd b_fwd;		\
 +    defvar_bool (&b_fwd, lname, &globals.f_ ## vname);		\
 +  } while (false)
 +#define DEFVAR_INT(lname, vname, doc)		\
 +  do {						\
 +    static struct Lisp_Intfwd i_fwd;		\
 +    defvar_int (&i_fwd, lname, &globals.f_ ## vname);		\
 +  } while (false)
 +
 +#define DEFVAR_BUFFER_DEFAULTS(lname, vname, doc)		\
 +  do {								\
 +    static struct Lisp_Objfwd o_fwd;				\
 +    defvar_lisp_nopro (&o_fwd, lname, &BVAR (&buffer_defaults, vname));	\
 +  } while (false)
 +
 +#define DEFVAR_KBOARD(lname, vname, doc)			\
 +  do {								\
 +    static struct Lisp_Kboard_Objfwd ko_fwd;			\
 +    defvar_kboard (&ko_fwd, lname, offsetof (KBOARD, vname ## _)); \
 +  } while (false)
 +
 +/* Save and restore the instruction and environment pointers,
 +   without affecting the signal mask.  */
 +
 +#ifdef HAVE__SETJMP
 +typedef jmp_buf sys_jmp_buf;
 +# define sys_setjmp(j) _setjmp (j)
 +# define sys_longjmp(j, v) _longjmp (j, v)
 +#elif defined HAVE_SIGSETJMP
 +typedef sigjmp_buf sys_jmp_buf;
 +# define sys_setjmp(j) sigsetjmp (j, 0)
 +# define sys_longjmp(j, v) siglongjmp (j, v)
 +#else
 +/* A platform that uses neither _longjmp nor siglongjmp; assume
 +   longjmp does not affect the sigmask.  */
 +typedef jmp_buf sys_jmp_buf;
 +# define sys_setjmp(j) setjmp (j)
 +# define sys_longjmp(j, v) longjmp (j, v)
 +#endif
 +
 +
 +/* Elisp uses several stacks:
 +   - the C stack.
 +   - the bytecode stack: used internally by the bytecode interpreter.
 +     Allocated from the C stack.
 +   - The specpdl stack: keeps track of active unwind-protect and
 +     dynamic-let-bindings.  Allocated from the `specpdl' array, a manually
 +     managed stack.
 +   - The handler stack: keeps track of active catch tags and condition-case
 +     handlers.  Allocated in a manually managed stack implemented by a
 +     doubly-linked list allocated via xmalloc and never freed.  */
 +
 +/* Structure for recording Lisp call stack for backtrace purposes.  */
 +
 +/* The special binding stack holds the outer values of variables while
 +   they are bound by a function application or a let form, stores the
 +   code to be executed for unwind-protect forms.
 +
 +   NOTE: The specbinding union is defined here, because SPECPDL_INDEX is
 +   used all over the place, needs to be fast, and needs to know the size of
 +   union specbinding.  But only eval.c should access it.  */
 +
 +enum specbind_tag {
 +  SPECPDL_UNWIND,		/* An unwind_protect function on Lisp_Object.  */
 +  SPECPDL_UNWIND_PTR,		/* Likewise, on void *.  */
 +  SPECPDL_UNWIND_INT,		/* Likewise, on int.  */
 +  SPECPDL_UNWIND_VOID,		/* Likewise, with no arg.  */
 +  SPECPDL_BACKTRACE,		/* An element of the backtrace.  */
 +  SPECPDL_LET,			/* A plain and simple dynamic let-binding.  */
 +  /* Tags greater than SPECPDL_LET must be "subkinds" of LET.  */
 +  SPECPDL_LET_LOCAL,		/* A buffer-local let-binding.  */
 +  SPECPDL_LET_DEFAULT		/* A global binding for a localized var.  */
 +};
 +
 +union specbinding
 +  {
 +    ENUM_BF (specbind_tag) kind : CHAR_BIT;
 +    struct {
 +      ENUM_BF (specbind_tag) kind : CHAR_BIT;
 +      void (*func) (Lisp_Object);
 +      Lisp_Object arg;
 +    } unwind;
 +    struct {
 +      ENUM_BF (specbind_tag) kind : CHAR_BIT;
 +      void (*func) (void *);
 +      void *arg;
 +    } unwind_ptr;
 +    struct {
 +      ENUM_BF (specbind_tag) kind : CHAR_BIT;
 +      void (*func) (int);
 +      int arg;
 +    } unwind_int;
 +    struct {
 +      ENUM_BF (specbind_tag) kind : CHAR_BIT;
 +      void (*func) (void);
 +    } unwind_void;
 +    struct {
 +      ENUM_BF (specbind_tag) kind : CHAR_BIT;
 +      /* `where' is not used in the case of SPECPDL_LET.  */
 +      Lisp_Object symbol, old_value, where;
 +    } let;
 +    struct {
 +      ENUM_BF (specbind_tag) kind : CHAR_BIT;
 +      bool_bf debug_on_exit : 1;
 +      Lisp_Object function;
 +      Lisp_Object *args;
 +      ptrdiff_t nargs;
 +    } bt;
 +  };
 +
 +extern union specbinding *specpdl;
 +extern union specbinding *specpdl_ptr;
 +extern ptrdiff_t specpdl_size;
 +
 +INLINE ptrdiff_t
 +SPECPDL_INDEX (void)
 +{
 +  return specpdl_ptr - specpdl;
 +}
 +
 +/* This structure helps implement the `catch/throw' and `condition-case/signal'
 +   control structures.  A struct handler contains all the information needed to
 +   restore the state of the interpreter after a non-local jump.
 +
 +   handler structures are chained together in a doubly linked list; the `next'
 +   member points to the next outer catchtag and the `nextfree' member points in
 +   the other direction to the next inner element (which is typically the next
 +   free element since we mostly use it on the deepest handler).
 +
 +   A call like (throw TAG VAL) searches for a catchtag whose `tag_or_ch'
 +   member is TAG, and then unbinds to it.  The `val' member is used to
 +   hold VAL while the stack is unwound; `val' is returned as the value
 +   of the catch form.
 +
 +   All the other members are concerned with restoring the interpreter
 +   state.
 +
 +   Members are volatile if their values need to survive _longjmp when
 +   a 'struct handler' is a local variable.  */
 +
 +enum handlertype { CATCHER, CONDITION_CASE };
 +
 +struct handler
 +{
 +  enum handlertype type;
 +  Lisp_Object tag_or_ch;
 +  Lisp_Object val;
 +  struct handler *next;
 +  struct handler *nextfree;
 +
 +  /* The bytecode interpreter can have several handlers active at the same
 +     time, so when we longjmp to one of them, it needs to know which handler
 +     this was and what was the corresponding internal state.  This is stored
 +     here, and when we longjmp we make sure that handlerlist points to the
 +     proper handler.  */
 +  Lisp_Object *bytecode_top;
 +  int bytecode_dest;
 +
 +  /* Most global vars are reset to their value via the specpdl mechanism,
 +     but a few others are handled by storing their value here.  */
 +#if true /* GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS, but defined later.  */
 +  struct gcpro *gcpro;
 +#endif
 +  sys_jmp_buf jmp;
 +  EMACS_INT lisp_eval_depth;
 +  ptrdiff_t pdlcount;
 +  int poll_suppress_count;
 +  int interrupt_input_blocked;
 +  struct byte_stack *byte_stack;
 +};
 +
 +/* Fill in the components of c, and put it on the list.  */
 +#define PUSH_HANDLER(c, tag_ch_val, handlertype)	\
 +  if (handlerlist->nextfree)				\
 +    (c) = handlerlist->nextfree;			\
 +  else							\
 +    {							\
 +      (c) = xmalloc (sizeof (struct handler));		\
 +      (c)->nextfree = NULL;				\
 +      handlerlist->nextfree = (c);			\
 +    }							\
 +  (c)->type = (handlertype);				\
 +  (c)->tag_or_ch = (tag_ch_val);			\
 +  (c)->val = Qnil;					\
 +  (c)->next = handlerlist;				\
 +  (c)->lisp_eval_depth = lisp_eval_depth;		\
 +  (c)->pdlcount = SPECPDL_INDEX ();			\
 +  (c)->poll_suppress_count = poll_suppress_count;	\
 +  (c)->interrupt_input_blocked = interrupt_input_blocked;\
 +  (c)->gcpro = gcprolist;				\
 +  (c)->byte_stack = byte_stack_list;			\
 +  handlerlist = (c);
 +
 +
 +extern Lisp_Object memory_signal_data;
 +
 +/* An address near the bottom of the stack.
 +   Tells GC how to save a copy of the stack.  */
 +extern char *stack_bottom;
 +
 +/* Check quit-flag and quit if it is non-nil.
 +   Typing C-g does not directly cause a quit; it only sets Vquit_flag.
 +   So the program needs to do QUIT at times when it is safe to quit.
 +   Every loop that might run for a long time or might not exit
 +   ought to do QUIT at least once, at a safe place.
 +   Unless that is impossible, of course.
 +   But it is very desirable to avoid creating loops where QUIT is impossible.
 +
 +   Exception: if you set immediate_quit to true,
 +   then the handler that responds to the C-g does the quit itself.
 +   This is a good thing to do around a loop that has no side effects
 +   and (in particular) cannot call arbitrary Lisp code.
 +
 +   If quit-flag is set to `kill-emacs' the SIGINT handler has received
 +   a request to exit Emacs when it is safe to do.  */
 +
 +extern void process_pending_signals (void);
 +extern bool volatile pending_signals;
 +
 +extern void process_quit_flag (void);
 +#define QUIT						\
 +  do {							\
 +    if (!NILP (Vquit_flag) && NILP (Vinhibit_quit))	\
 +      process_quit_flag ();				\
 +    else if (pending_signals)				\
 +      process_pending_signals ();			\
 +  } while (false)
 +
 +
 +/* True if ought to quit now.  */
 +
 +#define QUITP (!NILP (Vquit_flag) && NILP (Vinhibit_quit))
 +
 +extern Lisp_Object Vascii_downcase_table;
 +extern Lisp_Object Vascii_canon_table;
 +
 +/* Structure for recording stack slots that need marking.  */
 +
 +/* This is a chain of structures, each of which points at a Lisp_Object
 +   variable whose value should be marked in garbage collection.
 +   Normally every link of the chain is an automatic variable of a function,
 +   and its `val' points to some argument or local variable of the function.
 +   On exit to the function, the chain is set back to the value it had on entry.
 +   This way, no link remains in the chain when the stack frame containing the
 +   link disappears.
 +
 +   Every function that can call Feval must protect in this fashion all
 +   Lisp_Object variables whose contents will be used again.  */
 +
 +extern struct gcpro *gcprolist;
 +
 +struct gcpro
 +{
 +  struct gcpro *next;
 +
 +  /* Address of first protected variable.  */
 +  volatile Lisp_Object *var;
 +
 +  /* Number of consecutive protected variables.  */
 +  ptrdiff_t nvars;
 +
 +#ifdef DEBUG_GCPRO
 +  /* File name where this record is used.  */
 +  const char *name;
 +
 +  /* Line number in this file.  */
 +  int lineno;
 +
 +  /* Index in the local chain of records.  */
 +  int idx;
 +
 +  /* Nesting level.  */
 +  int level;
 +#endif
 +};
 +
 +/* Values of GC_MARK_STACK during compilation:
 +
 +   0	Use GCPRO as before
 +   1	Do the real thing, make GCPROs and UNGCPRO no-ops.
 +   2    Mark the stack, and check that everything GCPRO'd is
 +	marked.
 +   3	Mark using GCPRO's, mark stack last, and count how many
 +	dead objects are kept alive.
 +
 +   Formerly, method 0 was used.  Currently, method 1 is used unless
 +   otherwise specified by hand when building, e.g.,
 +   "make CPPFLAGS='-DGC_MARK_STACK=GC_USE_GCPROS_AS_BEFORE'".
 +   Methods 2 and 3 are present mainly to debug the transition from 0 to 1.  */
 +
 +#define GC_USE_GCPROS_AS_BEFORE		0
 +#define GC_MAKE_GCPROS_NOOPS		1
 +#define GC_MARK_STACK_CHECK_GCPROS	2
 +#define GC_USE_GCPROS_CHECK_ZOMBIES	3
 +
 +#ifndef GC_MARK_STACK
 +#define GC_MARK_STACK GC_MAKE_GCPROS_NOOPS
 +#endif
 +
 +/* Whether we do the stack marking manually.  */
 +#define BYTE_MARK_STACK !(GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS		\
 +			  || GC_MARK_STACK == GC_MARK_STACK_CHECK_GCPROS)
 +
 +
 +#if GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS
 +
 +/* Do something silly with gcproN vars just so gcc shuts up.  */
 +/* You get warnings from MIPSPro...  */
 +
 +#define GCPRO1(varname) ((void) gcpro1)
 +#define GCPRO2(varname1, varname2) ((void) gcpro2, (void) gcpro1)
 +#define GCPRO3(varname1, varname2, varname3) \
 +  ((void) gcpro3, (void) gcpro2, (void) gcpro1)
 +#define GCPRO4(varname1, varname2, varname3, varname4) \
 +  ((void) gcpro4, (void) gcpro3, (void) gcpro2, (void) gcpro1)
 +#define GCPRO5(varname1, varname2, varname3, varname4, varname5) \
 +  ((void) gcpro5, (void) gcpro4, (void) gcpro3, (void) gcpro2, (void) gcpro1)
 +#define GCPRO6(varname1, varname2, varname3, varname4, varname5, varname6) \
 +  ((void) gcpro6, (void) gcpro5, (void) gcpro4, (void) gcpro3, (void) gcpro2, \
 +   (void) gcpro1)
 +#define GCPRO7(a, b, c, d, e, f, g) (GCPRO6 (a, b, c, d, e, f), (void) gcpro7)
 +#define UNGCPRO ((void) 0)
 +
 +#else /* GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS */
 +
 +#ifndef DEBUG_GCPRO
 +
 +#define GCPRO1(a)							\
 +  { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1;	\
 +    gcprolist = &gcpro1; }
 +
 +#define GCPRO2(a, b)							\
 +  { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1;	\
 +    gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1;		\
 +    gcprolist = &gcpro2; }
 +
 +#define GCPRO3(a, b, c)							\
 +  { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1;	\
 +    gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1;		\
 +    gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1;		\
 +    gcprolist = &gcpro3; }
 +
 +#define GCPRO4(a, b, c, d)						\
 +  { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1;	\
 +    gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1;		\
 +    gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1;		\
 +    gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1;		\
 +    gcprolist = &gcpro4; }
 +
 +#define GCPRO5(a, b, c, d, e)						\
 +  { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1;	\
 +    gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1;		\
 +    gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1;		\
 +    gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1;		\
 +    gcpro5.next = &gcpro4; gcpro5.var = &(e); gcpro5.nvars = 1;		\
 +    gcprolist = &gcpro5; }
 +
 +#define GCPRO6(a, b, c, d, e, f)					\
 +  { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1;	\
 +    gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1;		\
 +    gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1;		\
 +    gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1;		\
 +    gcpro5.next = &gcpro4; gcpro5.var = &(e); gcpro5.nvars = 1;		\
 +    gcpro6.next = &gcpro5; gcpro6.var = &(f); gcpro6.nvars = 1;		\
 +    gcprolist = &gcpro6; }
 +
 +#define GCPRO7(a, b, c, d, e, f, g)					\
 +  { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1;	\
 +    gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1;		\
 +    gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1;		\
 +    gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1;		\
 +    gcpro5.next = &gcpro4; gcpro5.var = &(e); gcpro5.nvars = 1;		\
 +    gcpro6.next = &gcpro5; gcpro6.var = &(f); gcpro6.nvars = 1;		\
 +    gcpro7.next = &gcpro6; gcpro7.var = &(g); gcpro7.nvars = 1;		\
 +    gcprolist = &gcpro7; }
 +
 +#define UNGCPRO (gcprolist = gcpro1.next)
 +
 +#else /* !DEBUG_GCPRO */
 +
 +extern int gcpro_level;
 +
 +#define GCPRO1(a)							\
 +  { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1;	\
 +    gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1;	\
 +    gcpro1.level = gcpro_level++;					\
 +    gcprolist = &gcpro1; }
 +
 +#define GCPRO2(a, b)							\
 +  { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1;	\
 +    gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1;	\
 +    gcpro1.level = gcpro_level;					   	\
 +    gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1;		\
 +    gcpro2.name = __FILE__; gcpro2.lineno = __LINE__; gcpro2.idx = 2;	\
 +    gcpro2.level = gcpro_level++;					\
 +    gcprolist = &gcpro2; }
 +
 +#define GCPRO3(a, b, c)							\
 +  { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1;	\
 +    gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1;	\
 +    gcpro1.level = gcpro_level;						\
 +    gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1;		\
 +    gcpro2.name = __FILE__; gcpro2.lineno = __LINE__; gcpro2.idx = 2;	\
 +    gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1;		\
 +    gcpro3.name = __FILE__; gcpro3.lineno = __LINE__; gcpro3.idx = 3;	\
 +    gcpro3.level = gcpro_level++;					\
 +    gcprolist = &gcpro3; }
 +
 +#define GCPRO4(a, b, c, d)						\
 +  { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1;	\
 +    gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1;	\
 +    gcpro1.level = gcpro_level;						\
 +    gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1;		\
 +    gcpro2.name = __FILE__; gcpro2.lineno = __LINE__; gcpro2.idx = 2;	\
 +    gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1;		\
 +    gcpro3.name = __FILE__; gcpro3.lineno = __LINE__; gcpro3.idx = 3;	\
 +    gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1;		\
 +    gcpro4.name = __FILE__; gcpro4.lineno = __LINE__; gcpro4.idx = 4;	\
 +    gcpro4.level = gcpro_level++;					\
 +    gcprolist = &gcpro4; }
 +
 +#define GCPRO5(a, b, c, d, e)						\
 +  { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1;	\
 +    gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1;	\
 +    gcpro1.level = gcpro_level;						\
 +    gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1;		\
 +    gcpro2.name = __FILE__; gcpro2.lineno = __LINE__; gcpro2.idx = 2;	\
 +    gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1;		\
 +    gcpro3.name = __FILE__; gcpro3.lineno = __LINE__; gcpro3.idx = 3;	\
 +    gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1;		\
 +    gcpro4.name = __FILE__; gcpro4.lineno = __LINE__; gcpro4.idx = 4;	\
 +    gcpro5.next = &gcpro4; gcpro5.var = &(e); gcpro5.nvars = 1;		\
 +    gcpro5.name = __FILE__; gcpro5.lineno = __LINE__; gcpro5.idx = 5;	\
 +    gcpro5.level = gcpro_level++;					\
 +    gcprolist = &gcpro5; }
 +
 +#define GCPRO6(a, b, c, d, e, f)					\
 +  { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1;	\
 +    gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1;	\
 +    gcpro1.level = gcpro_level;						\
 +    gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1;		\
 +    gcpro2.name = __FILE__; gcpro2.lineno = __LINE__; gcpro2.idx = 2;	\
 +    gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1;		\
 +    gcpro3.name = __FILE__; gcpro3.lineno = __LINE__; gcpro3.idx = 3;	\
 +    gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1;		\
 +    gcpro4.name = __FILE__; gcpro4.lineno = __LINE__; gcpro4.idx = 4;	\
 +    gcpro5.next = &gcpro4; gcpro5.var = &(e); gcpro5.nvars = 1;		\
 +    gcpro5.name = __FILE__; gcpro5.lineno = __LINE__; gcpro5.idx = 5;	\
 +    gcpro6.next = &gcpro5; gcpro6.var = &(f); gcpro6.nvars = 1;		\
 +    gcpro6.name = __FILE__; gcpro6.lineno = __LINE__; gcpro6.idx = 6;	\
 +    gcpro6.level = gcpro_level++;					\
 +    gcprolist = &gcpro6; }
 +
 +#define GCPRO7(a, b, c, d, e, f, g)					\
 +  { gcpro1.next = gcprolist; gcpro1.var = &(a); gcpro1.nvars = 1;	\
 +    gcpro1.name = __FILE__; gcpro1.lineno = __LINE__; gcpro1.idx = 1;	\
 +    gcpro1.level = gcpro_level;						\
 +    gcpro2.next = &gcpro1; gcpro2.var = &(b); gcpro2.nvars = 1;		\
 +    gcpro2.name = __FILE__; gcpro2.lineno = __LINE__; gcpro2.idx = 2;	\
 +    gcpro3.next = &gcpro2; gcpro3.var = &(c); gcpro3.nvars = 1;		\
 +    gcpro3.name = __FILE__; gcpro3.lineno = __LINE__; gcpro3.idx = 3;	\
 +    gcpro4.next = &gcpro3; gcpro4.var = &(d); gcpro4.nvars = 1;		\
 +    gcpro4.name = __FILE__; gcpro4.lineno = __LINE__; gcpro4.idx = 4;	\
 +    gcpro5.next = &gcpro4; gcpro5.var = &(e); gcpro5.nvars = 1;		\
 +    gcpro5.name = __FILE__; gcpro5.lineno = __LINE__; gcpro5.idx = 5;	\
 +    gcpro6.next = &gcpro5; gcpro6.var = &(f); gcpro6.nvars = 1;		\
 +    gcpro6.name = __FILE__; gcpro6.lineno = __LINE__; gcpro6.idx = 6;	\
 +    gcpro7.next = &gcpro6; gcpro7.var = &(g); gcpro7.nvars = 1;		\
 +    gcpro7.name = __FILE__; gcpro7.lineno = __LINE__; gcpro7.idx = 7;	\
 +    gcpro7.level = gcpro_level++;					\
 +    gcprolist = &gcpro7; }
 +
 +#define UNGCPRO					\
 +  (--gcpro_level != gcpro1.level		\
 +   ? emacs_abort ()				\
 +   : (void) (gcprolist = gcpro1.next))
 +
 +#endif /* DEBUG_GCPRO */
 +#endif /* GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS */
 +
 +
 +/* Evaluate expr, UNGCPRO, and then return the value of expr.  */
 +#define RETURN_UNGCPRO(expr)			\
 +  do						\
 +    {						\
 +      Lisp_Object ret_ungc_val;			\
 +      ret_ungc_val = (expr);			\
 +      UNGCPRO;					\
 +      return ret_ungc_val;			\
 +    }						\
 +  while (false)
 +
 +/* Call staticpro (&var) to protect static variable `var'.  */
 +
 +void staticpro (Lisp_Object *);
 +
 +/* Forward declarations for prototypes.  */
 +struct window;
 +struct frame;
 +
 +/* Copy COUNT Lisp_Objects from ARGS to contents of V starting from OFFSET.  */
 +
 +INLINE void
 +vcopy (Lisp_Object v, ptrdiff_t offset, Lisp_Object *args, ptrdiff_t count)
 +{
 +  eassert (0 <= offset && 0 <= count && offset + count <= ASIZE (v));
 +  memcpy (XVECTOR (v)->contents + offset, args, count * sizeof *args);
 +}
 +
 +/* Functions to modify hash tables.  */
 +
 +INLINE void
 +set_hash_key_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val)
 +{
 +  gc_aset (h->key_and_value, 2 * idx, val);
 +}
 +
 +INLINE void
 +set_hash_value_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, Lisp_Object val)
 +{
 +  gc_aset (h->key_and_value, 2 * idx + 1, val);
 +}
 +
 +/* Use these functions to set Lisp_Object
 +   or pointer slots of struct Lisp_Symbol.  */
 +
 +INLINE void
 +set_symbol_function (Lisp_Object sym, Lisp_Object function)
 +{
 +  XSYMBOL (sym)->function = function;
 +}
 +
 +INLINE void
 +set_symbol_plist (Lisp_Object sym, Lisp_Object plist)
 +{
 +  XSYMBOL (sym)->plist = plist;
 +}
 +
 +INLINE void
 +set_symbol_next (Lisp_Object sym, struct Lisp_Symbol *next)
 +{
 +  XSYMBOL (sym)->next = next;
 +}
 +
 +/* Buffer-local (also frame-local) variable access functions.  */
 +
 +INLINE int
 +blv_found (struct Lisp_Buffer_Local_Value *blv)
 +{
 +  eassert (blv->found == !EQ (blv->defcell, blv->valcell));
 +  return blv->found;
 +}
 +
 +/* Set overlay's property list.  */
 +
 +INLINE void
 +set_overlay_plist (Lisp_Object overlay, Lisp_Object plist)
 +{
 +  XOVERLAY (overlay)->plist = plist;
 +}
 +
 +/* Get text properties of S.  */
 +
 +INLINE INTERVAL
 +string_intervals (Lisp_Object s)
 +{
 +  return XSTRING (s)->intervals;
 +}
 +
 +/* Set text properties of S to I.  */
 +
 +INLINE void
 +set_string_intervals (Lisp_Object s, INTERVAL i)
 +{
 +  XSTRING (s)->intervals = i;
 +}
 +
 +/* Set a Lisp slot in TABLE to VAL.  Most code should use this instead
 +   of setting slots directly.  */
 +
 +INLINE void
 +set_char_table_defalt (Lisp_Object table, Lisp_Object val)
 +{
 +  XCHAR_TABLE (table)->defalt = val;
 +}
 +INLINE void
 +set_char_table_purpose (Lisp_Object table, Lisp_Object val)
 +{
 +  XCHAR_TABLE (table)->purpose = val;
 +}
 +
 +/* Set different slots in (sub)character tables.  */
 +
 +INLINE void
 +set_char_table_extras (Lisp_Object table, ptrdiff_t idx, Lisp_Object val)
 +{
 +  eassert (0 <= idx && idx < CHAR_TABLE_EXTRA_SLOTS (XCHAR_TABLE (table)));
 +  XCHAR_TABLE (table)->extras[idx] = val;
 +}
 +
 +INLINE void
 +set_char_table_contents (Lisp_Object table, ptrdiff_t idx, Lisp_Object val)
 +{
 +  eassert (0 <= idx && idx < (1 << CHARTAB_SIZE_BITS_0));
 +  XCHAR_TABLE (table)->contents[idx] = val;
 +}
 +
 +INLINE void
 +set_sub_char_table_contents (Lisp_Object table, ptrdiff_t idx, Lisp_Object val)
 +{
 +  XSUB_CHAR_TABLE (table)->contents[idx] = val;
 +}
 +
 +/* Defined in data.c.  */
 +extern Lisp_Object indirect_function (Lisp_Object);
 +extern Lisp_Object find_symbol_value (Lisp_Object);
 +enum Arith_Comparison {
 +  ARITH_EQUAL,
 +  ARITH_NOTEQUAL,
 +  ARITH_LESS,
 +  ARITH_GRTR,
 +  ARITH_LESS_OR_EQUAL,
 +  ARITH_GRTR_OR_EQUAL
 +};
 +extern Lisp_Object arithcompare (Lisp_Object num1, Lisp_Object num2,
 +                                 enum Arith_Comparison comparison);
 +
 +/* Convert the integer I to an Emacs representation, either the integer
 +   itself, or a cons of two or three integers, or if all else fails a float.
 +   I should not have side effects.  */
 +#define INTEGER_TO_CONS(i)					    \
 +  (! FIXNUM_OVERFLOW_P (i)					    \
 +   ? make_number (i)						    \
 +   : ! ((FIXNUM_OVERFLOW_P (INTMAX_MIN >> 16)			    \
 +	 || FIXNUM_OVERFLOW_P (UINTMAX_MAX >> 16))		    \
 +	&& FIXNUM_OVERFLOW_P ((i) >> 16))			    \
 +   ? Fcons (make_number ((i) >> 16), make_number ((i) & 0xffff))    \
 +   : ! ((FIXNUM_OVERFLOW_P (INTMAX_MIN >> 16 >> 24)		    \
 +	 || FIXNUM_OVERFLOW_P (UINTMAX_MAX >> 16 >> 24))	    \
 +	&& FIXNUM_OVERFLOW_P ((i) >> 16 >> 24))			    \
 +   ? Fcons (make_number ((i) >> 16 >> 24),			    \
 +	    Fcons (make_number ((i) >> 16 & 0xffffff),		    \
 +		   make_number ((i) & 0xffff)))			    \
 +   : make_float (i))
 +
 +/* Convert the Emacs representation CONS back to an integer of type
 +   TYPE, storing the result the variable VAR.  Signal an error if CONS
 +   is not a valid representation or is out of range for TYPE.  */
 +#define CONS_TO_INTEGER(cons, type, var)				\
 + (TYPE_SIGNED (type)							\
 +  ? ((var) = cons_to_signed (cons, TYPE_MINIMUM (type), TYPE_MAXIMUM (type))) \
 +  : ((var) = cons_to_unsigned (cons, TYPE_MAXIMUM (type))))
 +extern intmax_t cons_to_signed (Lisp_Object, intmax_t, intmax_t);
 +extern uintmax_t cons_to_unsigned (Lisp_Object, uintmax_t);
 +
 +extern struct Lisp_Symbol *indirect_variable (struct Lisp_Symbol *);
 +extern _Noreturn void args_out_of_range (Lisp_Object, Lisp_Object);
 +extern _Noreturn void args_out_of_range_3 (Lisp_Object, Lisp_Object,
 +					   Lisp_Object);
 +extern Lisp_Object do_symval_forwarding (union Lisp_Fwd *);
 +extern void set_internal (Lisp_Object, Lisp_Object, Lisp_Object, bool);
 +extern void syms_of_data (void);
 +extern void swap_in_global_binding (struct Lisp_Symbol *);
 +
 +/* Defined in cmds.c */
 +extern void syms_of_cmds (void);
 +extern void keys_of_cmds (void);
 +
 +/* Defined in coding.c.  */
 +extern Lisp_Object detect_coding_system (const unsigned char *, ptrdiff_t,
 +                                         ptrdiff_t, bool, bool, Lisp_Object);
 +extern void init_coding (void);
 +extern void init_coding_once (void);
 +extern void syms_of_coding (void);
 +
 +/* Defined in character.c.  */
 +extern ptrdiff_t chars_in_text (const unsigned char *, ptrdiff_t);
 +extern ptrdiff_t multibyte_chars_in_text (const unsigned char *, ptrdiff_t);
 +extern void syms_of_character (void);
 +
 +/* Defined in charset.c.  */
 +extern void init_charset (void);
 +extern void init_charset_once (void);
 +extern void syms_of_charset (void);
 +/* Structure forward declarations.  */
 +struct charset;
 +
 +/* Defined in syntax.c.  */
 +extern void init_syntax_once (void);
 +extern void syms_of_syntax (void);
 +
 +/* Defined in fns.c.  */
 +enum { NEXT_ALMOST_PRIME_LIMIT = 11 };
 +extern EMACS_INT next_almost_prime (EMACS_INT) ATTRIBUTE_CONST;
 +extern Lisp_Object larger_vector (Lisp_Object, ptrdiff_t, ptrdiff_t);
 +extern void sweep_weak_hash_tables (void);
 +EMACS_UINT hash_string (char const *, ptrdiff_t);
 +EMACS_UINT sxhash (Lisp_Object, int);
 +Lisp_Object make_hash_table (struct hash_table_test, Lisp_Object, Lisp_Object,
 +                             Lisp_Object, Lisp_Object);
 +ptrdiff_t hash_lookup (struct Lisp_Hash_Table *, Lisp_Object, EMACS_UINT *);
 +ptrdiff_t hash_put (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object,
 +		    EMACS_UINT);
 +extern struct hash_table_test hashtest_eql, hashtest_equal;
 +extern void validate_subarray (Lisp_Object, Lisp_Object, Lisp_Object,
 +			       ptrdiff_t, ptrdiff_t *, ptrdiff_t *);
 +extern Lisp_Object substring_both (Lisp_Object, ptrdiff_t, ptrdiff_t,
 +				   ptrdiff_t, ptrdiff_t);
 +extern Lisp_Object merge (Lisp_Object, Lisp_Object, Lisp_Object);
 +extern Lisp_Object do_yes_or_no_p (Lisp_Object);
 +extern Lisp_Object concat2 (Lisp_Object, Lisp_Object);
 +extern Lisp_Object concat3 (Lisp_Object, Lisp_Object, Lisp_Object);
 +extern Lisp_Object nconc2 (Lisp_Object, Lisp_Object);
 +extern Lisp_Object assq_no_quit (Lisp_Object, Lisp_Object);
 +extern Lisp_Object assoc_no_quit (Lisp_Object, Lisp_Object);
 +extern void clear_string_char_byte_cache (void);
 +extern ptrdiff_t string_char_to_byte (Lisp_Object, ptrdiff_t);
 +extern ptrdiff_t string_byte_to_char (Lisp_Object, ptrdiff_t);
 +extern Lisp_Object string_to_multibyte (Lisp_Object);
 +extern Lisp_Object string_make_unibyte (Lisp_Object);
 +extern void syms_of_fns (void);
 +
 +/* Defined in floatfns.c.  */
 +extern void syms_of_floatfns (void);
 +extern Lisp_Object fmod_float (Lisp_Object x, Lisp_Object y);
 +
 +/* Defined in fringe.c.  */
 +extern void syms_of_fringe (void);
 +extern void init_fringe (void);
 +#ifdef HAVE_WINDOW_SYSTEM
 +extern void mark_fringe_data (void);
 +extern void init_fringe_once (void);
 +#endif /* HAVE_WINDOW_SYSTEM */
 +
 +/* Defined in image.c.  */
 +extern int x_bitmap_mask (struct frame *, ptrdiff_t);
 +extern void reset_image_types (void);
 +extern void syms_of_image (void);
 +
 +/* Defined in insdel.c.  */
 +extern void move_gap_both (ptrdiff_t, ptrdiff_t);
 +extern _Noreturn void buffer_overflow (void);
 +extern void make_gap (ptrdiff_t);
 +extern void make_gap_1 (struct buffer *, ptrdiff_t);
 +extern ptrdiff_t copy_text (const unsigned char *, unsigned char *,
 +			    ptrdiff_t, bool, bool);
 +extern int count_combining_before (const unsigned char *,
 +				   ptrdiff_t, ptrdiff_t, ptrdiff_t);
 +extern int count_combining_after (const unsigned char *,
 +				  ptrdiff_t, ptrdiff_t, ptrdiff_t);
 +extern void insert (const char *, ptrdiff_t);
 +extern void insert_and_inherit (const char *, ptrdiff_t);
 +extern void insert_1_both (const char *, ptrdiff_t, ptrdiff_t,
 +			   bool, bool, bool);
 +extern void insert_from_gap (ptrdiff_t, ptrdiff_t, bool text_at_gap_tail);
 +extern void insert_from_string (Lisp_Object, ptrdiff_t, ptrdiff_t,
 +				ptrdiff_t, ptrdiff_t, bool);
 +extern void insert_from_buffer (struct buffer *, ptrdiff_t, ptrdiff_t, bool);
 +extern void insert_char (int);
 +extern void insert_string (const char *);
 +extern void insert_before_markers (const char *, ptrdiff_t);
 +extern void insert_before_markers_and_inherit (const char *, ptrdiff_t);
 +extern void insert_from_string_before_markers (Lisp_Object, ptrdiff_t,
 +					       ptrdiff_t, ptrdiff_t,
 +					       ptrdiff_t, bool);
 +extern void del_range (ptrdiff_t, ptrdiff_t);
 +extern Lisp_Object del_range_1 (ptrdiff_t, ptrdiff_t, bool, bool);
 +extern void del_range_byte (ptrdiff_t, ptrdiff_t, bool);
 +extern void del_range_both (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, bool);
 +extern Lisp_Object del_range_2 (ptrdiff_t, ptrdiff_t,
 +				ptrdiff_t, ptrdiff_t, bool);
 +extern void modify_text (ptrdiff_t, ptrdiff_t);
 +extern void prepare_to_modify_buffer (ptrdiff_t, ptrdiff_t, ptrdiff_t *);
 +extern void prepare_to_modify_buffer_1 (ptrdiff_t, ptrdiff_t, ptrdiff_t *);
 +extern void invalidate_buffer_caches (struct buffer *, ptrdiff_t, ptrdiff_t);
 +extern void signal_after_change (ptrdiff_t, ptrdiff_t, ptrdiff_t);
 +extern void adjust_after_insert (ptrdiff_t, ptrdiff_t, ptrdiff_t,
 +				 ptrdiff_t, ptrdiff_t);
 +extern void adjust_markers_for_delete (ptrdiff_t, ptrdiff_t,
 +				       ptrdiff_t, ptrdiff_t);
 +extern void replace_range (ptrdiff_t, ptrdiff_t, Lisp_Object, bool, bool, bool);
 +extern void replace_range_2 (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t,
 +			     const char *, ptrdiff_t, ptrdiff_t, bool);
 +extern void syms_of_insdel (void);
 +
 +/* Defined in dispnew.c.  */
 +#if (defined PROFILING \
 +     && (defined __FreeBSD__ || defined GNU_LINUX || defined __MINGW32__))
 +_Noreturn void __executable_start (void);
 +#endif
 +extern Lisp_Object Vwindow_system;
 +extern Lisp_Object sit_for (Lisp_Object, bool, int);
 +
 +/* Defined in xdisp.c.  */
 +extern bool noninteractive_need_newline;
 +extern Lisp_Object echo_area_buffer[2];
 +extern void add_to_log (const char *, Lisp_Object, Lisp_Object);
 +extern void check_message_stack (void);
 +extern void setup_echo_area_for_printing (bool);
 +extern bool push_message (void);
 +extern void pop_message_unwind (void);
 +extern Lisp_Object restore_message_unwind (Lisp_Object);
 +extern void restore_message (void);
 +extern Lisp_Object current_message (void);
 +extern void clear_message (bool, bool);
 +extern void message (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2);
 +extern void message1 (const char *);
 +extern void message1_nolog (const char *);
 +extern void message3 (Lisp_Object);
 +extern void message3_nolog (Lisp_Object);
 +extern void message_dolog (const char *, ptrdiff_t, bool, bool);
 +extern void message_with_string (const char *, Lisp_Object, bool);
 +extern void message_log_maybe_newline (void);
 +extern void update_echo_area (void);
 +extern void truncate_echo_area (ptrdiff_t);
 +extern void redisplay (void);
 +
 +void set_frame_cursor_types (struct frame *, Lisp_Object);
 +extern void syms_of_xdisp (void);
 +extern void init_xdisp (void);
 +extern Lisp_Object safe_eval (Lisp_Object);
 +extern bool pos_visible_p (struct window *, ptrdiff_t, int *,
 +			   int *, int *, int *, int *, int *);
 +
 +/* Defined in xsettings.c.  */
 +extern void syms_of_xsettings (void);
 +
 +/* Defined in vm-limit.c.  */
 +extern void memory_warnings (void *, void (*warnfun) (const char *));
 +
 +/* Defined in character.c.  */
 +extern void parse_str_as_multibyte (const unsigned char *, ptrdiff_t,
 +				    ptrdiff_t *, ptrdiff_t *);
 +
 +/* Defined in alloc.c.  */
 +extern void check_pure_size (void);
 +extern void free_misc (Lisp_Object);
 +extern void allocate_string_data (struct Lisp_String *, EMACS_INT, EMACS_INT);
 +extern void malloc_warning (const char *);
 +extern _Noreturn void memory_full (size_t);
 +extern _Noreturn void buffer_memory_full (ptrdiff_t);
 +extern bool survives_gc_p (Lisp_Object);
 +extern void mark_object (Lisp_Object);
 +#if defined REL_ALLOC && !defined SYSTEM_MALLOC && !defined HYBRID_MALLOC
 +extern void refill_memory_reserve (void);
 +#endif
 +extern const char *pending_malloc_warning;
 +extern Lisp_Object zero_vector;
 +extern Lisp_Object *stack_base;
 +extern EMACS_INT consing_since_gc;
 +extern EMACS_INT gc_relative_threshold;
 +extern EMACS_INT memory_full_cons_threshold;
 +extern Lisp_Object list1 (Lisp_Object);
 +extern Lisp_Object list2 (Lisp_Object, Lisp_Object);
 +extern Lisp_Object list3 (Lisp_Object, Lisp_Object, Lisp_Object);
 +extern Lisp_Object list4 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
 +extern Lisp_Object list5 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object,
 +			  Lisp_Object);
 +enum constype {CONSTYPE_HEAP, CONSTYPE_PURE};
 +extern Lisp_Object listn (enum constype, ptrdiff_t, Lisp_Object, ...);
 +
 +/* Build a frequently used 2/3/4-integer lists.  */
 +
 +INLINE Lisp_Object
 +list2i (EMACS_INT x, EMACS_INT y)
 +{
 +  return list2 (make_number (x), make_number (y));
 +}
 +
 +INLINE Lisp_Object
 +list3i (EMACS_INT x, EMACS_INT y, EMACS_INT w)
 +{
 +  return list3 (make_number (x), make_number (y), make_number (w));
 +}
 +
 +INLINE Lisp_Object
 +list4i (EMACS_INT x, EMACS_INT y, EMACS_INT w, EMACS_INT h)
 +{
 +  return list4 (make_number (x), make_number (y),
 +		make_number (w), make_number (h));
 +}
 +
 +extern Lisp_Object make_uninit_bool_vector (EMACS_INT);
 +extern Lisp_Object bool_vector_fill (Lisp_Object, Lisp_Object);
 +extern _Noreturn void string_overflow (void);
 +extern Lisp_Object make_string (const char *, ptrdiff_t);
 +extern Lisp_Object make_formatted_string (char *, const char *, ...)
 +  ATTRIBUTE_FORMAT_PRINTF (2, 3);
 +extern Lisp_Object make_unibyte_string (const char *, ptrdiff_t);
 +
 +/* Make unibyte string from C string when the length isn't known.  */
 +
 +INLINE Lisp_Object
 +build_unibyte_string (const char *str)
 +{
 +  return make_unibyte_string (str, strlen (str));
 +}
 +
 +extern Lisp_Object make_multibyte_string (const char *, ptrdiff_t, ptrdiff_t);
 +extern Lisp_Object make_event_array (ptrdiff_t, Lisp_Object *);
 +extern Lisp_Object make_uninit_string (EMACS_INT);
 +extern Lisp_Object make_uninit_multibyte_string (EMACS_INT, EMACS_INT);
 +extern Lisp_Object make_string_from_bytes (const char *, ptrdiff_t, ptrdiff_t);
 +extern Lisp_Object make_specified_string (const char *,
 +					  ptrdiff_t, ptrdiff_t, bool);
 +extern Lisp_Object make_pure_string (const char *, ptrdiff_t, ptrdiff_t, bool);
 +extern Lisp_Object make_pure_c_string (const char *, ptrdiff_t);
 +
 +/* Make a string allocated in pure space, use STR as string data.  */
 +
 +INLINE Lisp_Object
 +build_pure_c_string (const char *str)
 +{
 +  return make_pure_c_string (str, strlen (str));
 +}
 +
 +/* Make a string from the data at STR, treating it as multibyte if the
 +   data warrants.  */
 +
 +INLINE Lisp_Object
 +build_string (const char *str)
 +{
 +  return make_string (str, strlen (str));
 +}
 +
 +extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object);
 +extern void make_byte_code (struct Lisp_Vector *);
 +extern struct Lisp_Vector *allocate_vector (EMACS_INT);
 +
 +/* Make an uninitialized vector for SIZE objects.  NOTE: you must
 +   be sure that GC cannot happen until the vector is completely
 +   initialized.  E.g. the following code is likely to crash:
 +
 +   v = make_uninit_vector (3);
 +   ASET (v, 0, obj0);
 +   ASET (v, 1, Ffunction_can_gc ());
 +   ASET (v, 2, obj1);  */
 +
 +INLINE Lisp_Object
 +make_uninit_vector (ptrdiff_t size)
 +{
 +  Lisp_Object v;
 +  struct Lisp_Vector *p;
 +
 +  p = allocate_vector (size);
 +  XSETVECTOR (v, p);
 +  return v;
 +}
 +
 +/* Like above, but special for sub char-tables.  */
 +
 +INLINE Lisp_Object
 +make_uninit_sub_char_table (int depth, int min_char)
 +{
 +  int slots = SUB_CHAR_TABLE_OFFSET + chartab_size[depth];
 +  Lisp_Object v = make_uninit_vector (slots);
 +
 +  XSETPVECTYPE (XVECTOR (v), PVEC_SUB_CHAR_TABLE);
 +  XSUB_CHAR_TABLE (v)->depth = depth;
 +  XSUB_CHAR_TABLE (v)->min_char = min_char;
 +  return v;
 +}
 +
 +extern struct Lisp_Vector *allocate_pseudovector (int, int, int,
 +						  enum pvec_type);
 +
 +/* Allocate partially initialized pseudovector where all Lisp_Object
 +   slots are set to Qnil but the rest (if any) is left uninitialized.  */
 +
 +#define ALLOCATE_PSEUDOVECTOR(type, field, tag)			       \
 +  ((type *) allocate_pseudovector (VECSIZE (type),		       \
 +				   PSEUDOVECSIZE (type, field),	       \
 +				   PSEUDOVECSIZE (type, field), tag))
 +
 +/* Allocate fully initialized pseudovector where all Lisp_Object
 +   slots are set to Qnil and the rest (if any) is zeroed.  */
 +
 +#define ALLOCATE_ZEROED_PSEUDOVECTOR(type, field, tag)		       \
 +  ((type *) allocate_pseudovector (VECSIZE (type),		       \
 +				   PSEUDOVECSIZE (type, field),	       \
 +				   VECSIZE (type), tag))
 +
 +extern bool gc_in_progress;
 +extern bool abort_on_gc;
 +extern Lisp_Object make_float (double);
 +extern void display_malloc_warning (void);
 +extern ptrdiff_t inhibit_garbage_collection (void);
 +extern Lisp_Object make_save_int_int_int (ptrdiff_t, ptrdiff_t, ptrdiff_t);
 +extern Lisp_Object make_save_obj_obj_obj_obj (Lisp_Object, Lisp_Object,
 +					      Lisp_Object, Lisp_Object);
 +extern Lisp_Object make_save_ptr (void *);
 +extern Lisp_Object make_save_ptr_int (void *, ptrdiff_t);
 +extern Lisp_Object make_save_ptr_ptr (void *, void *);
 +extern Lisp_Object make_save_funcptr_ptr_obj (void (*) (void), void *,
 +					      Lisp_Object);
 +extern Lisp_Object make_save_memory (Lisp_Object *, ptrdiff_t);
 +extern void free_save_value (Lisp_Object);
 +extern Lisp_Object build_overlay (Lisp_Object, Lisp_Object, Lisp_Object);
 +extern void free_marker (Lisp_Object);
 +extern void free_cons (struct Lisp_Cons *);
 +extern void init_alloc_once (void);
 +extern void init_alloc (void);
 +extern void syms_of_alloc (void);
 +extern struct buffer * allocate_buffer (void);
 +extern int valid_lisp_object_p (Lisp_Object);
 +extern int relocatable_string_data_p (const char *);
 +#ifdef GC_CHECK_CONS_LIST
 +extern void check_cons_list (void);
 +#else
 +INLINE void (check_cons_list) (void) { lisp_h_check_cons_list (); }
 +#endif
 +
 +#ifdef REL_ALLOC
 +/* Defined in ralloc.c.  */
 +extern void *r_alloc (void **, size_t) ATTRIBUTE_ALLOC_SIZE ((2));
 +extern void r_alloc_free (void **);
 +extern void *r_re_alloc (void **, size_t) ATTRIBUTE_ALLOC_SIZE ((2));
 +extern void r_alloc_reset_variable (void **, void **);
 +extern void r_alloc_inhibit_buffer_relocation (int);
 +#endif
 +
 +/* Defined in chartab.c.  */
 +extern Lisp_Object copy_char_table (Lisp_Object);
 +extern Lisp_Object char_table_ref_and_range (Lisp_Object, int,
 +                                             int *, int *);
 +extern void char_table_set_range (Lisp_Object, int, int, Lisp_Object);
 +extern void map_char_table (void (*) (Lisp_Object, Lisp_Object,
 +                            Lisp_Object),
 +                            Lisp_Object, Lisp_Object, Lisp_Object);
 +extern void map_char_table_for_charset (void (*c_function) (Lisp_Object, Lisp_Object),
 +					Lisp_Object, Lisp_Object,
 +					Lisp_Object, struct charset *,
 +					unsigned, unsigned);
 +extern Lisp_Object uniprop_table (Lisp_Object);
 +extern void syms_of_chartab (void);
 +
 +/* Defined in print.c.  */
 +extern Lisp_Object Vprin1_to_string_buffer;
 +extern void debug_print (Lisp_Object) EXTERNALLY_VISIBLE;
 +extern void temp_output_buffer_setup (const char *);
 +extern int print_level;
 +extern void write_string (const char *);
 +extern void print_error_message (Lisp_Object, Lisp_Object, const char *,
 +				 Lisp_Object);
 +extern Lisp_Object internal_with_output_to_temp_buffer
 +        (const char *, Lisp_Object (*) (Lisp_Object), Lisp_Object);
 +#define FLOAT_TO_STRING_BUFSIZE 350
 +extern int float_to_string (char *, double);
 +extern void init_print_once (void);
 +extern void syms_of_print (void);
 +
 +/* Defined in doprnt.c.  */
 +extern ptrdiff_t doprnt (char *, ptrdiff_t, const char *, const char *,
 +			 va_list);
 +extern ptrdiff_t esprintf (char *, char const *, ...)
 +  ATTRIBUTE_FORMAT_PRINTF (2, 3);
 +extern ptrdiff_t exprintf (char **, ptrdiff_t *, char const *, ptrdiff_t,
 +			   char const *, ...)
 +  ATTRIBUTE_FORMAT_PRINTF (5, 6);
 +extern ptrdiff_t evxprintf (char **, ptrdiff_t *, char const *, ptrdiff_t,
 +			    char const *, va_list)
 +  ATTRIBUTE_FORMAT_PRINTF (5, 0);
 +
 +/* Defined in lread.c.  */
 +extern Lisp_Object check_obarray (Lisp_Object);
 +extern Lisp_Object intern_1 (const char *, ptrdiff_t);
 +extern Lisp_Object intern_c_string_1 (const char *, ptrdiff_t);
 +extern Lisp_Object intern_driver (Lisp_Object, Lisp_Object, Lisp_Object);
 +extern void init_symbol (Lisp_Object, Lisp_Object);
 +extern Lisp_Object oblookup (Lisp_Object, const char *, ptrdiff_t, ptrdiff_t);
 +INLINE void
 +LOADHIST_ATTACH (Lisp_Object x)
 +{
 +  if (initialized)
 +    Vcurrent_load_list = Fcons (x, Vcurrent_load_list);
 +}
 +extern int openp (Lisp_Object, Lisp_Object, Lisp_Object,
 +                  Lisp_Object *, Lisp_Object, bool);
 +extern Lisp_Object string_to_number (char const *, int, bool);
 +extern void map_obarray (Lisp_Object, void (*) (Lisp_Object, Lisp_Object),
 +                         Lisp_Object);
 +extern void dir_warning (const char *, Lisp_Object);
 +extern void init_obarray (void);
 +extern void init_lread (void);
 +extern void syms_of_lread (void);
 +
 +INLINE Lisp_Object
 +intern (const char *str)
 +{
 +  return intern_1 (str, strlen (str));
 +}
 +
 +INLINE Lisp_Object
 +intern_c_string (const char *str)
 +{
 +  return intern_c_string_1 (str, strlen (str));
 +}
 +
 +/* Defined in eval.c.  */
 +extern EMACS_INT lisp_eval_depth;
 +extern Lisp_Object Vautoload_queue;
 +extern Lisp_Object Vrun_hooks;
 +extern Lisp_Object Vsignaling_function;
 +extern Lisp_Object inhibit_lisp_code;
 +extern struct handler *handlerlist;
 +
 +/* To run a normal hook, use the appropriate function from the list below.
 +   The calling convention:
 +
 +   if (!NILP (Vrun_hooks))
 +     call1 (Vrun_hooks, Qmy_funny_hook);
 +
 +   should no longer be used.  */
 +extern void run_hook (Lisp_Object);
 +extern void run_hook_with_args_2 (Lisp_Object, Lisp_Object, Lisp_Object);
 +extern Lisp_Object run_hook_with_args (ptrdiff_t nargs, Lisp_Object *args,
 +				       Lisp_Object (*funcall)
 +				       (ptrdiff_t nargs, Lisp_Object *args));
 +extern _Noreturn void xsignal (Lisp_Object, Lisp_Object);
 +extern _Noreturn void xsignal0 (Lisp_Object);
 +extern _Noreturn void xsignal1 (Lisp_Object, Lisp_Object);
 +extern _Noreturn void xsignal2 (Lisp_Object, Lisp_Object, Lisp_Object);
 +extern _Noreturn void xsignal3 (Lisp_Object, Lisp_Object, Lisp_Object,
 +				Lisp_Object);
 +extern _Noreturn void signal_error (const char *, Lisp_Object);
 +extern Lisp_Object eval_sub (Lisp_Object form);
 +extern Lisp_Object apply1 (Lisp_Object, Lisp_Object);
 +extern Lisp_Object call0 (Lisp_Object);
 +extern Lisp_Object call1 (Lisp_Object, Lisp_Object);
 +extern Lisp_Object call2 (Lisp_Object, Lisp_Object, Lisp_Object);
 +extern Lisp_Object call3 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
 +extern Lisp_Object call4 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
 +extern Lisp_Object call5 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
 +extern Lisp_Object call6 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
 +extern Lisp_Object call7 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
 +extern Lisp_Object internal_catch (Lisp_Object, Lisp_Object (*) (Lisp_Object), Lisp_Object);
 +extern Lisp_Object internal_lisp_condition_case (Lisp_Object, Lisp_Object, Lisp_Object);
 +extern Lisp_Object internal_condition_case (Lisp_Object (*) (void), Lisp_Object, Lisp_Object (*) (Lisp_Object));
 +extern Lisp_Object internal_condition_case_1 (Lisp_Object (*) (Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object));
 +extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object));
 +extern Lisp_Object internal_condition_case_n
 +    (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *,
 +     Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *));
 +extern void specbind (Lisp_Object, Lisp_Object);
 +extern void record_unwind_protect (void (*) (Lisp_Object), Lisp_Object);
 +extern void record_unwind_protect_ptr (void (*) (void *), void *);
 +extern void record_unwind_protect_int (void (*) (int), int);
 +extern void record_unwind_protect_void (void (*) (void));
 +extern void record_unwind_protect_nothing (void);
 +extern void clear_unwind_protect (ptrdiff_t);
 +extern void set_unwind_protect (ptrdiff_t, void (*) (Lisp_Object), Lisp_Object);
 +extern void set_unwind_protect_ptr (ptrdiff_t, void (*) (void *), void *);
 +extern Lisp_Object unbind_to (ptrdiff_t, Lisp_Object);
 +extern _Noreturn void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2);
 +extern _Noreturn void verror (const char *, va_list)
 +  ATTRIBUTE_FORMAT_PRINTF (1, 0);
 +extern void un_autoload (Lisp_Object);
 +extern Lisp_Object call_debugger (Lisp_Object arg);
 +extern void init_eval_once (void);
 +extern Lisp_Object safe_call (ptrdiff_t, Lisp_Object, ...);
 +extern Lisp_Object safe_call1 (Lisp_Object, Lisp_Object);
 +extern Lisp_Object safe_call2 (Lisp_Object, Lisp_Object, Lisp_Object);
 +extern void init_eval (void);
 +extern void syms_of_eval (void);
 +extern void unwind_body (Lisp_Object);
 +extern ptrdiff_t record_in_backtrace (Lisp_Object, Lisp_Object *, ptrdiff_t);
 +extern void mark_specpdl (void);
 +extern void get_backtrace (Lisp_Object array);
 +Lisp_Object backtrace_top_function (void);
 +extern bool let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol);
 +extern bool let_shadows_global_binding_p (Lisp_Object symbol);
 +
 +
 +/* Defined in editfns.c.  */
 +extern void insert1 (Lisp_Object);
 +extern Lisp_Object format2 (const char *, Lisp_Object, Lisp_Object);
 +extern Lisp_Object save_excursion_save (void);
 +extern Lisp_Object save_restriction_save (void);
 +extern void save_excursion_restore (Lisp_Object);
 +extern void save_restriction_restore (Lisp_Object);
 +extern _Noreturn void time_overflow (void);
 +extern Lisp_Object make_buffer_string (ptrdiff_t, ptrdiff_t, bool);
 +extern Lisp_Object make_buffer_string_both (ptrdiff_t, ptrdiff_t, ptrdiff_t,
 +					    ptrdiff_t, bool);
 +extern void init_editfns (void);
 +extern void syms_of_editfns (void);
 +
 +/* Defined in buffer.c.  */
 +extern bool mouse_face_overlay_overlaps (Lisp_Object);
 +extern _Noreturn void nsberror (Lisp_Object);
 +extern void adjust_overlays_for_insert (ptrdiff_t, ptrdiff_t);
 +extern void adjust_overlays_for_delete (ptrdiff_t, ptrdiff_t);
 +extern void fix_start_end_in_overlays (ptrdiff_t, ptrdiff_t);
 +extern void report_overlay_modification (Lisp_Object, Lisp_Object, bool,
 +                                         Lisp_Object, Lisp_Object, Lisp_Object);
 +extern bool overlay_touches_p (ptrdiff_t);
 +extern Lisp_Object other_buffer_safely (Lisp_Object);
 +extern Lisp_Object get_truename_buffer (Lisp_Object);
 +extern void init_buffer_once (void);
 +extern void init_buffer (int);
 +extern void syms_of_buffer (void);
 +extern void keys_of_buffer (void);
 +
 +/* Defined in marker.c.  */
 +
 +extern ptrdiff_t marker_position (Lisp_Object);
 +extern ptrdiff_t marker_byte_position (Lisp_Object);
 +extern void clear_charpos_cache (struct buffer *);
 +extern ptrdiff_t buf_charpos_to_bytepos (struct buffer *, ptrdiff_t);
 +extern ptrdiff_t buf_bytepos_to_charpos (struct buffer *, ptrdiff_t);
 +extern void unchain_marker (struct Lisp_Marker *marker);
 +extern Lisp_Object set_marker_restricted (Lisp_Object, Lisp_Object, Lisp_Object);
 +extern Lisp_Object set_marker_both (Lisp_Object, Lisp_Object, ptrdiff_t, ptrdiff_t);
 +extern Lisp_Object set_marker_restricted_both (Lisp_Object, Lisp_Object,
 +                                               ptrdiff_t, ptrdiff_t);
 +extern Lisp_Object build_marker (struct buffer *, ptrdiff_t, ptrdiff_t);
 +extern void syms_of_marker (void);
 +
 +/* Defined in fileio.c.  */
 +
 +extern Lisp_Object expand_and_dir_to_file (Lisp_Object, Lisp_Object);
 +extern Lisp_Object write_region (Lisp_Object, Lisp_Object, Lisp_Object,
 +				 Lisp_Object, Lisp_Object, Lisp_Object,
 +				 Lisp_Object, int);
 +extern void close_file_unwind (int);
 +extern void fclose_unwind (void *);
 +extern void restore_point_unwind (Lisp_Object);
 +extern _Noreturn void report_file_errno (const char *, Lisp_Object, int);
 +extern _Noreturn void report_file_error (const char *, Lisp_Object);
 +extern bool internal_delete_file (Lisp_Object);
 +extern Lisp_Object emacs_readlinkat (int, const char *);
 +extern bool file_directory_p (const char *);
 +extern bool file_accessible_directory_p (Lisp_Object);
 +extern void init_fileio (void);
 +extern void syms_of_fileio (void);
 +extern Lisp_Object make_temp_name (Lisp_Object, bool);
 +
 +/* Defined in search.c.  */
 +extern void shrink_regexp_cache (void);
 +extern void restore_search_regs (void);
 +extern void record_unwind_save_match_data (void);
 +struct re_registers;
 +extern struct re_pattern_buffer *compile_pattern (Lisp_Object,
 +						  struct re_registers *,
 +						  Lisp_Object, bool, bool);
 +extern ptrdiff_t fast_string_match_internal (Lisp_Object, Lisp_Object,
 +					     Lisp_Object);
 +
 +INLINE ptrdiff_t
 +fast_string_match (Lisp_Object regexp, Lisp_Object string)
 +{
 +  return fast_string_match_internal (regexp, string, Qnil);
 +}
 +
 +INLINE ptrdiff_t
 +fast_string_match_ignore_case (Lisp_Object regexp, Lisp_Object string)
 +{
 +  return fast_string_match_internal (regexp, string, Vascii_canon_table);
 +}
 +
 +extern ptrdiff_t fast_c_string_match_ignore_case (Lisp_Object, const char *,
 +						  ptrdiff_t);
 +extern ptrdiff_t fast_looking_at (Lisp_Object, ptrdiff_t, ptrdiff_t,
 +                                  ptrdiff_t, ptrdiff_t, Lisp_Object);
 +extern ptrdiff_t find_newline (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t,
 +			       ptrdiff_t, ptrdiff_t *, ptrdiff_t *, bool);
 +extern ptrdiff_t scan_newline (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t,
 +			       ptrdiff_t, bool);
 +extern ptrdiff_t scan_newline_from_point (ptrdiff_t, ptrdiff_t *, ptrdiff_t *);
 +extern ptrdiff_t find_newline_no_quit (ptrdiff_t, ptrdiff_t,
 +				       ptrdiff_t, ptrdiff_t *);
 +extern ptrdiff_t find_before_next_newline (ptrdiff_t, ptrdiff_t,
 +					   ptrdiff_t, ptrdiff_t *);
 +extern void syms_of_search (void);
 +extern void clear_regexp_cache (void);
 +
 +/* Defined in minibuf.c.  */
 +
 +extern Lisp_Object Vminibuffer_list;
 +extern Lisp_Object last_minibuf_string;
 +extern Lisp_Object get_minibuffer (EMACS_INT);
 +extern void init_minibuf_once (void);
 +extern void syms_of_minibuf (void);
 +
 +/* Defined in callint.c.  */
 +
 +extern void syms_of_callint (void);
 +
 +/* Defined in casefiddle.c.  */
 +
 +extern void syms_of_casefiddle (void);
 +extern void keys_of_casefiddle (void);
 +
 +/* Defined in casetab.c.  */
 +
 +extern void init_casetab_once (void);
 +extern void syms_of_casetab (void);
 +
 +/* Defined in keyboard.c.  */
 +
 +extern Lisp_Object echo_message_buffer;
 +extern struct kboard *echo_kboard;
 +extern void cancel_echoing (void);
 +extern Lisp_Object last_undo_boundary;
 +extern bool input_pending;
 +#ifdef HAVE_STACK_OVERFLOW_HANDLING
 +extern sigjmp_buf return_to_command_loop;
 +#endif
 +extern Lisp_Object menu_bar_items (Lisp_Object);
 +extern Lisp_Object tool_bar_items (Lisp_Object, int *);
 +extern void discard_mouse_events (void);
 +#ifdef USABLE_SIGIO
 +void handle_input_available_signal (int);
 +#endif
 +extern Lisp_Object pending_funcalls;
 +extern bool detect_input_pending (void);
 +extern bool detect_input_pending_ignore_squeezables (void);
 +extern bool detect_input_pending_run_timers (bool);
 +extern void safe_run_hooks (Lisp_Object);
 +extern void cmd_error_internal (Lisp_Object, const char *);
 +extern Lisp_Object command_loop_1 (void);
 +extern Lisp_Object read_menu_command (void);
 +extern Lisp_Object recursive_edit_1 (void);
 +extern void record_auto_save (void);
 +extern void force_auto_save_soon (void);
 +extern void init_keyboard (void);
 +extern void syms_of_keyboard (void);
 +extern void keys_of_keyboard (void);
 +
 +/* Defined in indent.c.  */
 +extern ptrdiff_t current_column (void);
 +extern void invalidate_current_column (void);
 +extern bool indented_beyond_p (ptrdiff_t, ptrdiff_t, EMACS_INT);
 +extern void syms_of_indent (void);
 +
 +/* Defined in frame.c.  */
 +extern void store_frame_param (struct frame *, Lisp_Object, Lisp_Object);
 +extern void store_in_alist (Lisp_Object *, Lisp_Object, Lisp_Object);
 +extern Lisp_Object do_switch_frame (Lisp_Object, int, int, Lisp_Object);
 +extern Lisp_Object get_frame_param (struct frame *, Lisp_Object);
 +extern void frames_discard_buffer (Lisp_Object);
 +extern void syms_of_frame (void);
 +
 +/* Defined in emacs.c.  */
 +extern char **initial_argv;
 +extern int initial_argc;
 +#if defined (HAVE_X_WINDOWS) || defined (HAVE_NS)
 +extern bool display_arg;
 +#endif
 +extern Lisp_Object decode_env_path (const char *, const char *, bool);
 +extern Lisp_Object empty_unibyte_string, empty_multibyte_string;
 +extern _Noreturn void terminate_due_to_signal (int, int);
 +#ifdef WINDOWSNT
 +extern Lisp_Object Vlibrary_cache;
 +#endif
 +#if HAVE_SETLOCALE
 +void fixup_locale (void);
 +void synchronize_system_messages_locale (void);
 +void synchronize_system_time_locale (void);
 +#else
 +INLINE void fixup_locale (void) {}
 +INLINE void synchronize_system_messages_locale (void) {}
 +INLINE void synchronize_system_time_locale (void) {}
 +#endif
 +extern void shut_down_emacs (int, Lisp_Object);
 +
 +/* True means don't do interactive redisplay and don't change tty modes.  */
 +extern bool noninteractive;
 +
 +/* True means remove site-lisp directories from load-path.  */
 +extern bool no_site_lisp;
 +
 +/* Pipe used to send exit notification to the daemon parent at
 +   startup.  On Windows, we use a kernel event instead.  */
 +#ifndef WINDOWSNT
 +extern int daemon_pipe[2];
 +#define IS_DAEMON (daemon_pipe[1] != 0)
 +#define DAEMON_RUNNING (daemon_pipe[1] >= 0)
 +#else  /* WINDOWSNT */
 +extern void *w32_daemon_event;
 +#define IS_DAEMON (w32_daemon_event != NULL)
 +#define DAEMON_RUNNING (w32_daemon_event != INVALID_HANDLE_VALUE)
 +#endif
 +
 +/* True if handling a fatal error already.  */
 +extern bool fatal_error_in_progress;
 +
 +/* True means don't do use window-system-specific display code.  */
 +extern bool inhibit_window_system;
 +/* True means that a filter or a sentinel is running.  */
 +extern bool running_asynch_code;
 +
 +/* Defined in process.c.  */
 +extern void kill_buffer_processes (Lisp_Object);
 +extern int wait_reading_process_output (intmax_t, int, int, bool, Lisp_Object,
 +					struct Lisp_Process *, int);
 +/* Max value for the first argument of wait_reading_process_output.  */
 +#if __GNUC__ == 3 || (__GNUC__ == 4 && __GNUC_MINOR__ <= 5)
 +/* Work around a bug in GCC 3.4.2, known to be fixed in GCC 4.6.3.
 +   The bug merely causes a bogus warning, but the warning is annoying.  */
 +# define WAIT_READING_MAX min (TYPE_MAXIMUM (time_t), INTMAX_MAX)
 +#else
 +# define WAIT_READING_MAX INTMAX_MAX
 +#endif
 +#ifdef HAVE_TIMERFD
 +extern void add_timer_wait_descriptor (int);
 +#endif
 +extern void add_keyboard_wait_descriptor (int);
 +extern void delete_keyboard_wait_descriptor (int);
 +#ifdef HAVE_GPM
 +extern void add_gpm_wait_descriptor (int);
 +extern void delete_gpm_wait_descriptor (int);
 +#endif
 +extern void init_process_emacs (void);
 +extern void syms_of_process (void);
 +extern void setup_process_coding_systems (Lisp_Object);
 +
 +/* Defined in callproc.c.  */
 +#ifndef DOS_NT
 + _Noreturn
 +#endif
 +extern int child_setup (int, int, int, char **, bool, Lisp_Object);
 +extern void init_callproc_1 (void);
 +extern void init_callproc (void);
 +extern void set_initial_environment (void);
 +extern void syms_of_callproc (void);
 +
 +/* Defined in doc.c.  */
 +extern Lisp_Object read_doc_string (Lisp_Object);
 +extern Lisp_Object get_doc_string (Lisp_Object, bool, bool);
 +extern void syms_of_doc (void);
 +extern int read_bytecode_char (bool);
 +
 +/* Defined in bytecode.c.  */
 +extern void syms_of_bytecode (void);
 +extern struct byte_stack *byte_stack_list;
 +#if BYTE_MARK_STACK
 +extern void mark_byte_stack (void);
 +#endif
 +extern void unmark_byte_stack (void);
 +extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object,
 +				   Lisp_Object, ptrdiff_t, Lisp_Object *);
 +
 +/* Defined in macros.c.  */
 +extern void init_macros (void);
 +extern void syms_of_macros (void);
 +
 +/* Defined in undo.c.  */
 +extern void truncate_undo_list (struct buffer *);
 +extern void record_insert (ptrdiff_t, ptrdiff_t);
 +extern void record_delete (ptrdiff_t, Lisp_Object, bool);
 +extern void record_first_change (void);
 +extern void record_change (ptrdiff_t, ptrdiff_t);
 +extern void record_property_change (ptrdiff_t, ptrdiff_t,
 +				    Lisp_Object, Lisp_Object,
 +                                    Lisp_Object);
 +extern void syms_of_undo (void);
 +
 +/* Defined in textprop.c.  */
 +extern void report_interval_modification (Lisp_Object, Lisp_Object);
 +
 +/* Defined in menu.c.  */
 +extern void syms_of_menu (void);
 +
 +/* Defined in xmenu.c.  */
 +extern void syms_of_xmenu (void);
 +
 +/* Defined in termchar.h.  */
 +struct tty_display_info;
 +
 +/* Defined in termhooks.h.  */
 +struct terminal;
 +
 +/* Defined in sysdep.c.  */
 +#ifndef HAVE_GET_CURRENT_DIR_NAME
 +extern char *get_current_dir_name (void);
 +#endif
 +extern void stuff_char (char c);
 +extern void init_foreground_group (void);
 +extern void sys_subshell (void);
 +extern void sys_suspend (void);
 +extern void discard_tty_input (void);
 +extern void init_sys_modes (struct tty_display_info *);
 +extern void reset_sys_modes (struct tty_display_info *);
 +extern void init_all_sys_modes (void);
 +extern void reset_all_sys_modes (void);
 +extern void child_setup_tty (int);
 +extern void setup_pty (int);
 +extern int set_window_size (int, int, int);
 +extern EMACS_INT get_random (void);
 +extern void seed_random (void *, ptrdiff_t);
 +extern void init_random (void);
 +extern void emacs_backtrace (int);
 +extern _Noreturn void emacs_abort (void) NO_INLINE;
 +extern int emacs_open (const char *, int, int);
 +extern int emacs_pipe (int[2]);
 +extern int emacs_close (int);
 +extern ptrdiff_t emacs_read (int, void *, ptrdiff_t);
 +extern ptrdiff_t emacs_write (int, void const *, ptrdiff_t);
 +extern ptrdiff_t emacs_write_sig (int, void const *, ptrdiff_t);
 +extern void emacs_perror (char const *);
 +
 +extern void unlock_all_files (void);
 +extern void lock_file (Lisp_Object);
 +extern void unlock_file (Lisp_Object);
 +extern void unlock_buffer (struct buffer *);
 +extern void syms_of_filelock (void);
 +extern int str_collate (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
 +
 +/* Defined in sound.c.  */
 +extern void syms_of_sound (void);
 +
 +/* Defined in category.c.  */
 +extern void init_category_once (void);
 +extern Lisp_Object char_category_set (int);
 +extern void syms_of_category (void);
 +
 +/* Defined in ccl.c.  */
 +extern void syms_of_ccl (void);
 +
 +/* Defined in dired.c.  */
 +extern void syms_of_dired (void);
 +extern Lisp_Object directory_files_internal (Lisp_Object, Lisp_Object,
 +                                             Lisp_Object, Lisp_Object,
 +                                             bool, Lisp_Object);
 +
 +/* Defined in term.c.  */
 +extern int *char_ins_del_vector;
 +extern void syms_of_term (void);
 +extern _Noreturn void fatal (const char *msgid, ...)
 +  ATTRIBUTE_FORMAT_PRINTF (1, 2);
 +
 +/* Defined in terminal.c.  */
 +extern void syms_of_terminal (void);
 +
 +/* Defined in font.c.  */
 +extern void syms_of_font (void);
 +extern void init_font (void);
 +
 +#ifdef HAVE_WINDOW_SYSTEM
 +/* Defined in fontset.c.  */
 +extern void syms_of_fontset (void);
 +#endif
 +
 +/* Defined in gfilenotify.c */
 +#ifdef HAVE_GFILENOTIFY
 +extern void globals_of_gfilenotify (void);
 +extern void syms_of_gfilenotify (void);
 +#endif
 +
 +/* Defined in inotify.c */
 +#ifdef HAVE_INOTIFY
 +extern void syms_of_inotify (void);
 +#endif
 +
 +#ifdef HAVE_W32NOTIFY
 +/* Defined on w32notify.c.  */
 +extern void syms_of_w32notify (void);
 +#endif
 +
 +/* Defined in xfaces.c.  */
 +extern Lisp_Object Vface_alternative_font_family_alist;
 +extern Lisp_Object Vface_alternative_font_registry_alist;
 +extern void syms_of_xfaces (void);
 +
 +#ifdef HAVE_X_WINDOWS
 +/* Defined in xfns.c.  */
 +extern void syms_of_xfns (void);
 +
 +/* Defined in xsmfns.c.  */
 +extern void syms_of_xsmfns (void);
 +
 +/* Defined in xselect.c.  */
 +extern void syms_of_xselect (void);
 +
 +/* Defined in xterm.c.  */
 +extern void init_xterm (void);
 +extern void syms_of_xterm (void);
 +#endif /* HAVE_X_WINDOWS */
 +
 +#ifdef HAVE_WINDOW_SYSTEM
 +/* Defined in xterm.c, nsterm.m, w32term.c.  */
 +extern char *x_get_keysym_name (int);
 +#endif /* HAVE_WINDOW_SYSTEM */
 +
 +#ifdef HAVE_LIBXML2
 +/* Defined in xml.c.  */
 +extern void syms_of_xml (void);
 +extern void xml_cleanup_parser (void);
 +#endif
 +
 +#ifdef HAVE_ZLIB
 +/* Defined in decompress.c.  */
 +extern void syms_of_decompress (void);
 +#endif
 +
 +#ifdef HAVE_DBUS
 +/* Defined in dbusbind.c.  */
 +void init_dbusbind (void);
 +void syms_of_dbusbind (void);
 +#endif
 +
 +
 +/* Defined in profiler.c.  */
 +extern bool profiler_memory_running;
 +extern void malloc_probe (size_t);
 +extern void syms_of_profiler (void);
 +
 +
 +#ifdef DOS_NT
 +/* Defined in msdos.c, w32.c.  */
 +extern char *emacs_root_dir (void);
 +#endif /* DOS_NT */
 +
 +/* Defined in lastfile.c.  */
 +extern char my_edata[];
 +extern char my_endbss[];
 +extern char *my_endbss_static;
 +
 +/* True means ^G can quit instantly.  */
 +extern bool immediate_quit;
 +
 +extern void *xmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
 +extern void *xzalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1));
 +extern void *xrealloc (void *, size_t) ATTRIBUTE_ALLOC_SIZE ((2));
 +extern void xfree (void *);
 +extern void *xnmalloc (ptrdiff_t, ptrdiff_t) ATTRIBUTE_MALLOC_SIZE ((1,2));
 +extern void *xnrealloc (void *, ptrdiff_t, ptrdiff_t)
 +  ATTRIBUTE_ALLOC_SIZE ((2,3));
 +extern void *xpalloc (void *, ptrdiff_t *, ptrdiff_t, ptrdiff_t, ptrdiff_t);
 +
 +extern char *xstrdup (const char *) ATTRIBUTE_MALLOC;
 +extern char *xlispstrdup (Lisp_Object) ATTRIBUTE_MALLOC;
 +extern void dupstring (char **, char const *);
 +
 +/* Make DEST a copy of STRING's data.  Return a pointer to DEST's terminating
 +   null byte.  This is like stpcpy, except the source is a Lisp string.  */
 +
 +INLINE char *
 +lispstpcpy (char *dest, Lisp_Object string)
 +{
 +  ptrdiff_t len = SBYTES (string);
 +  memcpy (dest, SDATA (string), len + 1);
 +  return dest + len;
 +}
 +
 +extern void xputenv (const char *);
 +
 +extern char *egetenv_internal (const char *, ptrdiff_t);
 +
 +INLINE char *
 +egetenv (const char *var)
 +{
 +  /* When VAR is a string literal, strlen can be optimized away.  */
 +  return egetenv_internal (var, strlen (var));
 +}
 +
 +/* Set up the name of the machine we're running on.  */
 +extern void init_system_name (void);
 +
 +/* Return the absolute value of X.  X should be a signed integer
 +   expression without side effects, and X's absolute value should not
 +   exceed the maximum for its promoted type.  This is called 'eabs'
 +   because 'abs' is reserved by the C standard.  */
 +#define eabs(x)         ((x) < 0 ? -(x) : (x))
 +
 +/* Return a fixnum or float, depending on whether VAL fits in a Lisp
 +   fixnum.  */
 +
 +#define make_fixnum_or_float(val) \
 +   (FIXNUM_OVERFLOW_P (val) ? make_float (val) : make_number (val))
 +
 +/* SAFE_ALLOCA normally allocates memory on the stack, but if size is
 +   larger than MAX_ALLOCA, use xmalloc to avoid overflowing the stack.  */
 +
 +enum MAX_ALLOCA { MAX_ALLOCA = 16 * 1024 };
 +
 +extern void *record_xmalloc (size_t) ATTRIBUTE_ALLOC_SIZE ((1));
 +
 +#define USE_SAFE_ALLOCA			\
 +  ptrdiff_t sa_avail = MAX_ALLOCA;	\
 +  ptrdiff_t sa_count = SPECPDL_INDEX (); bool sa_must_free = false
 +
 +#define AVAIL_ALLOCA(size) (sa_avail -= (size), alloca (size))
 +
 +/* SAFE_ALLOCA allocates a simple buffer.  */
 +
 +#define SAFE_ALLOCA(size) ((size) <= sa_avail				\
 +			   ? AVAIL_ALLOCA (size)			\
 +			   : (sa_must_free = true, record_xmalloc (size)))
 +
 +/* SAFE_NALLOCA sets BUF to a newly allocated array of MULTIPLIER *
 +   NITEMS items, each of the same type as *BUF.  MULTIPLIER must
 +   positive.  The code is tuned for MULTIPLIER being a constant.  */
 +
 +#define SAFE_NALLOCA(buf, multiplier, nitems)			 \
 +  do {								 \
 +    if ((nitems) <= sa_avail / sizeof *(buf) / (multiplier))	 \
 +      (buf) = AVAIL_ALLOCA (sizeof *(buf) * (multiplier) * (nitems)); \
 +    else							 \
 +      {								 \
 +	(buf) = xnmalloc (nitems, sizeof *(buf) * (multiplier)); \
 +	sa_must_free = true;					 \
 +	record_unwind_protect_ptr (xfree, buf);			 \
 +      }								 \
 +  } while (false)
 +
 +/* SAFE_ALLOCA_STRING allocates a C copy of a Lisp string.  */
 +
 +#define SAFE_ALLOCA_STRING(ptr, string)			\
 +  do {							\
 +    (ptr) = SAFE_ALLOCA (SBYTES (string) + 1);		\
 +    memcpy (ptr, SDATA (string), SBYTES (string) + 1);	\
 +  } while (false)
 +
 +/* SAFE_FREE frees xmalloced memory and enables GC as needed.  */
 +
 +#define SAFE_FREE()			\
 +  do {					\
 +    if (sa_must_free) {			\
 +      sa_must_free = false;		\
 +      unbind_to (sa_count, Qnil);	\
 +    }					\
 +  } while (false)
 +
 +
 +/* Return floor (NBYTES / WORD_SIZE).  */
 +
 +INLINE ptrdiff_t
 +lisp_word_count (ptrdiff_t nbytes)
 +{
 +  if (-1 >> 1 == -1)
 +    switch (word_size)
 +      {
 +      case 2: return nbytes >> 1;
 +      case 4: return nbytes >> 2;
 +      case 8: return nbytes >> 3;
 +      case 16: return nbytes >> 4;
 +      }
 +  return nbytes / word_size - (nbytes % word_size < 0);
 +}
 +
 +/* SAFE_ALLOCA_LISP allocates an array of Lisp_Objects.  */
 +
 +#define SAFE_ALLOCA_LISP(buf, nelt)			       \
 +  do {							       \
 +    if ((nelt) <= lisp_word_count (sa_avail))		       \
 +      (buf) = AVAIL_ALLOCA ((nelt) * word_size);	       \
 +    else if ((nelt) <= min (PTRDIFF_MAX, SIZE_MAX) / word_size) \
 +      {							       \
 +	Lisp_Object arg_;				       \
 +	(buf) = xmalloc ((nelt) * word_size);		       \
 +	arg_ = make_save_memory (buf, nelt);		       \
 +	sa_must_free = true;				       \
 +	record_unwind_protect (free_save_value, arg_);	       \
 +      }							       \
 +    else						       \
 +      memory_full (SIZE_MAX);				       \
 +  } while (false)
 +
 +
 +/* If USE_STACK_LISP_OBJECTS, define macros that and functions that allocate
 +   block-scoped conses and strings.  These objects are not
 +   managed by the garbage collector, so they are dangerous: passing them
 +   out of their scope (e.g., to user code) results in undefined behavior.
 +   Conversely, they have better performance because GC is not involved.
 +
 +   This feature is experimental and requires careful debugging.
 +   Build with CPPFLAGS='-DUSE_STACK_LISP_OBJECTS=0' to disable it.  */
 +
 +#ifndef USE_STACK_LISP_OBJECTS
 +# define USE_STACK_LISP_OBJECTS true
 +#endif
 +
 +/* USE_STACK_LISP_OBJECTS requires GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS.  */
 +
 +#if GC_MARK_STACK != GC_MAKE_GCPROS_NOOPS
 +# undef USE_STACK_LISP_OBJECTS
 +# define USE_STACK_LISP_OBJECTS false
 +#endif
 +
 +#ifdef GC_CHECK_STRING_BYTES
 +enum { defined_GC_CHECK_STRING_BYTES = true };
 +#else
 +enum { defined_GC_CHECK_STRING_BYTES = false };
 +#endif
 +
 +/* Struct inside unions that are typically no larger and aligned enough.  */
 +
 +union Aligned_Cons
 +{
 +  struct Lisp_Cons s;
 +  double d; intmax_t i; void *p;
 +};
 +
 +union Aligned_String
 +{
 +  struct Lisp_String s;
 +  double d; intmax_t i; void *p;
 +};
 +
 +/* True for stack-based cons and string implementations, respectively.
 +   Use stack-based strings only if stack-based cons also works.
 +   Otherwise, STACK_CONS would create heap-based cons cells that
 +   could point to stack-based strings, which is a no-no.  */
 +
 +enum
 +  {
 +    USE_STACK_CONS = (USE_STACK_LISP_OBJECTS
 +		      && alignof (union Aligned_Cons) % GCALIGNMENT == 0),
 +    USE_STACK_STRING = (USE_STACK_CONS
 +			&& !defined_GC_CHECK_STRING_BYTES
 +			&& alignof (union Aligned_String) % GCALIGNMENT == 0)
 +  };
 +
 +/* Auxiliary macros used for auto allocation of Lisp objects.  Please
 +   use these only in macros like AUTO_CONS that declare a local
 +   variable whose lifetime will be clear to the programmer.  */
 +#define STACK_CONS(a, b) \
 +  make_lisp_ptr (&(union Aligned_Cons) { { a, { b } } }.s, Lisp_Cons)
 +#define AUTO_CONS_EXPR(a, b) \
 +  (USE_STACK_CONS ? STACK_CONS (a, b) : Fcons (a, b))
 +
 +/* Declare NAME as an auto Lisp cons or short list if possible, a
 +   GC-based one otherwise.  This is in the sense of the C keyword
 +   'auto'; i.e., the object has the lifetime of the containing block.
 +   The resulting object should not be made visible to user Lisp code.  */
 +
 +#define AUTO_CONS(name, a, b) Lisp_Object name = AUTO_CONS_EXPR (a, b)
 +#define AUTO_LIST1(name, a)						\
 +  Lisp_Object name = (USE_STACK_CONS ? STACK_CONS (a, Qnil) : list1 (a))
 +#define AUTO_LIST2(name, a, b)						\
 +  Lisp_Object name = (USE_STACK_CONS					\
 +		      ? STACK_CONS (a, STACK_CONS (b, Qnil))		\
 +		      : list2 (a, b))
 +#define AUTO_LIST3(name, a, b, c)					\
 +  Lisp_Object name = (USE_STACK_CONS					\
 +		      ? STACK_CONS (a, STACK_CONS (b, STACK_CONS (c, Qnil))) \
 +		      : list3 (a, b, c))
 +#define AUTO_LIST4(name, a, b, c, d)					\
 +    Lisp_Object name							\
 +      = (USE_STACK_CONS							\
 +	 ? STACK_CONS (a, STACK_CONS (b, STACK_CONS (c,			\
 +						     STACK_CONS (d, Qnil)))) \
 +	 : list4 (a, b, c, d))
 +
 +/* Check whether stack-allocated strings are ASCII-only.  */
 +
 +#if defined (ENABLE_CHECKING) && USE_STACK_LISP_OBJECTS
 +extern const char *verify_ascii (const char *);
 +#else
 +# define verify_ascii(str) (str)
 +#endif
 +
 +/* Declare NAME as an auto Lisp string if possible, a GC-based one if not.
 +   Take its value from STR.  STR is not necessarily copied and should
 +   contain only ASCII characters.  The resulting Lisp string should
 +   not be modified or made visible to user code.  */
 +
 +#define AUTO_STRING(name, str)						\
 +  Lisp_Object name =							\
 +    (USE_STACK_STRING							\
 +     ? (make_lisp_ptr							\
 +	((&(union Aligned_String)					\
 +	  {{strlen (str), -1, 0, (unsigned char *) verify_ascii (str)}}.s), \
 +	  Lisp_String))							\
 +     : build_string (verify_ascii (str)))
 +
 +/* Loop over all tails of a list, checking for cycles.
 +   FIXME: Make tortoise and n internal declarations.
 +   FIXME: Unroll the loop body so we don't need `n'.  */
 +#define FOR_EACH_TAIL(hare, list, tortoise, n)	\
 +  for ((tortoise) = (hare) = (list), (n) = true;		\
 +       CONSP (hare);						\
 +       (hare = XCDR (hare), (n) = !(n),				\
 +   	((n)							\
 +   	 ? (EQ (hare, tortoise)					\
 +	    ? xsignal1 (Qcircular_list, list)			\
 +	    : (void) 0)						\
 +	 /* Move tortoise before the next iteration, in case */ \
 +	 /* the next iteration does an Fsetcdr.  */		\
 +   	 : (void) ((tortoise) = XCDR (tortoise)))))
 +
 +/* Do a `for' loop over alist values.  */
 +
 +#define FOR_EACH_ALIST_VALUE(head_var, list_var, value_var)		\
 +  for ((list_var) = (head_var);						\
 +       (CONSP (list_var) && ((value_var) = XCDR (XCAR (list_var)), true)); \
 +       (list_var) = XCDR (list_var))
 +
 +/* Check whether it's time for GC, and run it if so.  */
 +
 +INLINE void
 +maybe_gc (void)
 +{
 +  if ((consing_since_gc > gc_cons_threshold
 +       && consing_since_gc > gc_relative_threshold)
 +      || (!NILP (Vmemory_full)
 +	  && consing_since_gc > memory_full_cons_threshold))
 +    Fgarbage_collect ();
 +}
 +
 +INLINE bool
 +functionp (Lisp_Object object)
 +{
 +  if (SYMBOLP (object) && !NILP (Ffboundp (object)))
 +    {
 +      object = Findirect_function (object, Qt);
 +
 +      if (CONSP (object) && EQ (XCAR (object), Qautoload))
 +	{
 +	  /* Autoloaded symbols are functions, except if they load
 +	     macros or keymaps.  */
 +	  int i;
 +	  for (i = 0; i < 4 && CONSP (object); i++)
 +	    object = XCDR (object);
 +
 +	  return ! (CONSP (object) && !NILP (XCAR (object)));
 +	}
 +    }
 +
 +  if (SUBRP (object))
 +    return XSUBR (object)->max_args != UNEVALLED;
 +  else if (COMPILEDP (object))
 +    return true;
 +  else if (CONSP (object))
 +    {
 +      Lisp_Object car = XCAR (object);
 +      return EQ (car, Qlambda) || EQ (car, Qclosure);
 +    }
 +  else
 +    return false;
 +}
 +
 +INLINE_HEADER_END
 +
 +#endif /* EMACS_LISP_H */
diff --cc test/manual/etags/c-src/emacs/src/regex.h
index f97c1cb38c1,00000000000..2ed6238730f
mode 100644,000000..100644
--- a/test/manual/etags/c-src/emacs/src/regex.h
+++ b/test/manual/etags/c-src/emacs/src/regex.h
@@@ -1,630 -1,0 +1,630 @@@
 +/* Definitions for data structures and routines for the regular
 +   expression library, version 0.12.
 +
-    Copyright (C) 1985, 1989-1993, 1995, 2000-2016 Free Software
++   Copyright (C) 1985, 1989-1993, 1995, 2000-2017 Free Software
 +   Foundation, Inc.
 +
 +   This program is free software; you can redistribute it and/or modify
 +   it under the terms of the GNU General Public License as published by
 +   the Free Software Foundation; either version 3, or (at your option)
 +   any later version.
 +
 +   This program is distributed in the hope that it will be useful,
 +   but WITHOUT ANY WARRANTY; without even the implied warranty of
 +   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +   GNU General Public License for more details.
 +
 +   You should have received a copy of the GNU General Public License
 +   along with this program.  If not, see .  */
 +
 +#ifndef _REGEX_H
 +#define _REGEX_H 1
 +
 +/* Allow the use in C++ code.  */
 +#ifdef __cplusplus
 +extern "C" {
 +#endif
 +
 +/* POSIX says that  must be included (by the caller) before
 +   .  */
 +
 +#if !defined _POSIX_C_SOURCE && !defined _POSIX_SOURCE && defined VMS
 +/* VMS doesn't have `size_t' in , even though POSIX says it
 +   should be there.  */
 +# include 
 +#endif
 +
 +/* The following bits are used to determine the regexp syntax we
 +   recognize.  The set/not-set meanings where historically chosen so
 +   that Emacs syntax had the value 0.
 +   The bits are given in alphabetical order, and
 +   the definitions shifted by one from the previous bit; thus, when we
 +   add or remove a bit, only one other definition need change.  */
 +typedef unsigned long reg_syntax_t;
 +
 +/* If this bit is not set, then \ inside a bracket expression is literal.
 +   If set, then such a \ quotes the following character.  */
 +#define RE_BACKSLASH_ESCAPE_IN_LISTS ((unsigned long int) 1)
 +
 +/* If this bit is not set, then + and ? are operators, and \+ and \? are
 +     literals.
 +   If set, then \+ and \? are operators and + and ? are literals.  */
 +#define RE_BK_PLUS_QM (RE_BACKSLASH_ESCAPE_IN_LISTS << 1)
 +
 +/* If this bit is set, then character classes are supported.  They are:
 +     [:alpha:], [:upper:], [:lower:],  [:digit:], [:alnum:], [:xdigit:],
 +     [:space:], [:print:], [:punct:], [:graph:], and [:cntrl:].
 +   If not set, then character classes are not supported.  */
 +#define RE_CHAR_CLASSES (RE_BK_PLUS_QM << 1)
 +
 +/* If this bit is set, then ^ and $ are always anchors (outside bracket
 +     expressions, of course).
 +   If this bit is not set, then it depends:
 +        ^  is an anchor if it is at the beginning of a regular
 +           expression or after an open-group or an alternation operator;
 +        $  is an anchor if it is at the end of a regular expression, or
 +           before a close-group or an alternation operator.
 +
 +   This bit could be (re)combined with RE_CONTEXT_INDEP_OPS, because
 +   POSIX draft 11.2 says that * etc. in leading positions is undefined.
 +   We already implemented a previous draft which made those constructs
 +   invalid, though, so we haven't changed the code back.  */
 +#define RE_CONTEXT_INDEP_ANCHORS (RE_CHAR_CLASSES << 1)
 +
 +/* If this bit is set, then special characters are always special
 +     regardless of where they are in the pattern.
 +   If this bit is not set, then special characters are special only in
 +     some contexts; otherwise they are ordinary.  Specifically,
 +     * + ? and intervals are only special when not after the beginning,
 +     open-group, or alternation operator.  */
 +#define RE_CONTEXT_INDEP_OPS (RE_CONTEXT_INDEP_ANCHORS << 1)
 +
 +/* If this bit is set, then *, +, ?, and { cannot be first in an re or
 +     immediately after an alternation or begin-group operator.  */
 +#define RE_CONTEXT_INVALID_OPS (RE_CONTEXT_INDEP_OPS << 1)
 +
 +/* If this bit is set, then . matches newline.
 +   If not set, then it doesn't.  */
 +#define RE_DOT_NEWLINE (RE_CONTEXT_INVALID_OPS << 1)
 +
 +/* If this bit is set, then . doesn't match NUL.
 +   If not set, then it does.  */
 +#define RE_DOT_NOT_NULL (RE_DOT_NEWLINE << 1)
 +
 +/* If this bit is set, nonmatching lists [^...] do not match newline.
 +   If not set, they do.  */
 +#define RE_HAT_LISTS_NOT_NEWLINE (RE_DOT_NOT_NULL << 1)
 +
 +/* If this bit is set, either \{...\} or {...} defines an
 +     interval, depending on RE_NO_BK_BRACES.
 +   If not set, \{, \}, {, and } are literals.  */
 +#define RE_INTERVALS (RE_HAT_LISTS_NOT_NEWLINE << 1)
 +
 +/* If this bit is set, +, ? and | aren't recognized as operators.
 +   If not set, they are.  */
 +#define RE_LIMITED_OPS (RE_INTERVALS << 1)
 +
 +/* If this bit is set, newline is an alternation operator.
 +   If not set, newline is literal.  */
 +#define RE_NEWLINE_ALT (RE_LIMITED_OPS << 1)
 +
 +/* If this bit is set, then `{...}' defines an interval, and \{ and \}
 +     are literals.
 +  If not set, then `\{...\}' defines an interval.  */
 +#define RE_NO_BK_BRACES (RE_NEWLINE_ALT << 1)
 +
 +/* If this bit is set, (...) defines a group, and \( and \) are literals.
 +   If not set, \(...\) defines a group, and ( and ) are literals.  */
 +#define RE_NO_BK_PARENS (RE_NO_BK_BRACES << 1)
 +
 +/* If this bit is set, then \ matches .
 +   If not set, then \ is a back-reference.  */
 +#define RE_NO_BK_REFS (RE_NO_BK_PARENS << 1)
 +
 +/* If this bit is set, then | is an alternation operator, and \| is literal.
 +   If not set, then \| is an alternation operator, and | is literal.  */
 +#define RE_NO_BK_VBAR (RE_NO_BK_REFS << 1)
 +
 +/* If this bit is set, then an ending range point collating higher
 +     than the starting range point, as in [z-a], is invalid.
 +   If not set, then when ending range point collates higher than the
 +     starting range point, the range is ignored.  */
 +#define RE_NO_EMPTY_RANGES (RE_NO_BK_VBAR << 1)
 +
 +/* If this bit is set, then an unmatched ) is ordinary.
 +   If not set, then an unmatched ) is invalid.  */
 +#define RE_UNMATCHED_RIGHT_PAREN_ORD (RE_NO_EMPTY_RANGES << 1)
 +
 +/* If this bit is set, succeed as soon as we match the whole pattern,
 +   without further backtracking.  */
 +#define RE_NO_POSIX_BACKTRACKING (RE_UNMATCHED_RIGHT_PAREN_ORD << 1)
 +
 +/* If this bit is set, do not process the GNU regex operators.
 +   If not set, then the GNU regex operators are recognized. */
 +#define RE_NO_GNU_OPS (RE_NO_POSIX_BACKTRACKING << 1)
 +
 +/* If this bit is set, then *?, +? and ?? match non greedily. */
 +#define RE_FRUGAL (RE_NO_GNU_OPS << 1)
 +
 +/* If this bit is set, then (?:...) is treated as a shy group.  */
 +#define RE_SHY_GROUPS (RE_FRUGAL << 1)
 +
 +/* If this bit is set, ^ and $ only match at beg/end of buffer.  */
 +#define RE_NO_NEWLINE_ANCHOR (RE_SHY_GROUPS << 1)
 +
 +/* If this bit is set, turn on internal regex debugging.
 +   If not set, and debugging was on, turn it off.
 +   This only works if regex.c is compiled -DDEBUG.
 +   We define this bit always, so that all that's needed to turn on
 +   debugging is to recompile regex.c; the calling code can always have
 +   this bit set, and it won't affect anything in the normal case. */
 +#define RE_DEBUG (RE_NO_NEWLINE_ANCHOR << 1)
 +
 +/* This global variable defines the particular regexp syntax to use (for
 +   some interfaces).  When a regexp is compiled, the syntax used is
 +   stored in the pattern buffer, so changing this does not affect
 +   already-compiled regexps.  */
 +extern reg_syntax_t re_syntax_options;
 +
 +#ifdef emacs
 +/* In Emacs, this is the string or buffer in which we
 +   are matching.  It is used for looking up syntax properties.  */
 +extern Lisp_Object re_match_object;
 +#endif
 +
 +/* Roughly the maximum number of failure points on the stack.  */
 +extern size_t re_max_failures;
 +
 +
 +/* Define combinations of the above bits for the standard possibilities.
 +   (The [[[ comments delimit what gets put into the Texinfo file, so
 +   don't delete them!)  */
 +/* [[[begin syntaxes]]] */
 +#define RE_SYNTAX_EMACS							\
 +  (RE_CHAR_CLASSES | RE_INTERVALS | RE_SHY_GROUPS | RE_FRUGAL)
 +
 +#define RE_SYNTAX_AWK							\
 +  (RE_BACKSLASH_ESCAPE_IN_LISTS   | RE_DOT_NOT_NULL			\
 +   | RE_NO_BK_PARENS              | RE_NO_BK_REFS			\
 +   | RE_NO_BK_VBAR                | RE_NO_EMPTY_RANGES			\
 +   | RE_DOT_NEWLINE		  | RE_CONTEXT_INDEP_ANCHORS		\
 +   | RE_UNMATCHED_RIGHT_PAREN_ORD | RE_NO_GNU_OPS)
 +
 +#define RE_SYNTAX_GNU_AWK						\
 +  ((RE_SYNTAX_POSIX_EXTENDED | RE_BACKSLASH_ESCAPE_IN_LISTS | RE_DEBUG)	\
 +   & ~(RE_DOT_NOT_NULL | RE_INTERVALS | RE_CONTEXT_INDEP_OPS))
 +
 +#define RE_SYNTAX_POSIX_AWK 						\
 +  (RE_SYNTAX_POSIX_EXTENDED | RE_BACKSLASH_ESCAPE_IN_LISTS		\
 +   | RE_INTERVALS	    | RE_NO_GNU_OPS)
 +
 +#define RE_SYNTAX_GREP							\
 +  (RE_BK_PLUS_QM              | RE_CHAR_CLASSES				\
 +   | RE_HAT_LISTS_NOT_NEWLINE | RE_INTERVALS				\
 +   | RE_NEWLINE_ALT)
 +
 +#define RE_SYNTAX_EGREP							\
 +  (RE_CHAR_CLASSES        | RE_CONTEXT_INDEP_ANCHORS			\
 +   | RE_CONTEXT_INDEP_OPS | RE_HAT_LISTS_NOT_NEWLINE			\
 +   | RE_NEWLINE_ALT       | RE_NO_BK_PARENS				\
 +   | RE_NO_BK_VBAR)
 +
 +#define RE_SYNTAX_POSIX_EGREP						\
 +  (RE_SYNTAX_EGREP | RE_INTERVALS | RE_NO_BK_BRACES)
 +
 +/* P1003.2/D11.2, section 4.20.7.1, lines 5078ff.  */
 +#define RE_SYNTAX_ED RE_SYNTAX_POSIX_BASIC
 +
 +#define RE_SYNTAX_SED RE_SYNTAX_POSIX_BASIC
 +
 +/* Syntax bits common to both basic and extended POSIX regex syntax.  */
 +#define _RE_SYNTAX_POSIX_COMMON						\
 +  (RE_CHAR_CLASSES | RE_DOT_NEWLINE      | RE_DOT_NOT_NULL		\
 +   | RE_INTERVALS  | RE_NO_EMPTY_RANGES)
 +
 +#define RE_SYNTAX_POSIX_BASIC						\
 +  (_RE_SYNTAX_POSIX_COMMON | RE_BK_PLUS_QM)
 +
 +/* Differs from ..._POSIX_BASIC only in that RE_BK_PLUS_QM becomes
 +   RE_LIMITED_OPS, i.e., \? \+ \| are not recognized.  Actually, this
 +   isn't minimal, since other operators, such as \`, aren't disabled.  */
 +#define RE_SYNTAX_POSIX_MINIMAL_BASIC					\
 +  (_RE_SYNTAX_POSIX_COMMON | RE_LIMITED_OPS)
 +
 +#define RE_SYNTAX_POSIX_EXTENDED					\
 +  (_RE_SYNTAX_POSIX_COMMON  | RE_CONTEXT_INDEP_ANCHORS			\
 +   | RE_CONTEXT_INDEP_OPS   | RE_NO_BK_BRACES				\
 +   | RE_NO_BK_PARENS        | RE_NO_BK_VBAR				\
 +   | RE_CONTEXT_INVALID_OPS | RE_UNMATCHED_RIGHT_PAREN_ORD)
 +
 +/* Differs from ..._POSIX_EXTENDED in that RE_CONTEXT_INDEP_OPS is
 +   removed and RE_NO_BK_REFS is added.  */
 +#define RE_SYNTAX_POSIX_MINIMAL_EXTENDED				\
 +  (_RE_SYNTAX_POSIX_COMMON  | RE_CONTEXT_INDEP_ANCHORS			\
 +   | RE_CONTEXT_INVALID_OPS | RE_NO_BK_BRACES				\
 +   | RE_NO_BK_PARENS        | RE_NO_BK_REFS				\
 +   | RE_NO_BK_VBAR	    | RE_UNMATCHED_RIGHT_PAREN_ORD)
 +/* [[[end syntaxes]]] */
 +
 +/* Maximum number of duplicates an interval can allow.  Some systems
 +   (erroneously) define this in other header files, but we want our
 +   value, so remove any previous define.  */
 +#ifdef RE_DUP_MAX
 +# undef RE_DUP_MAX
 +#endif
 +/* If sizeof(int) == 2, then ((1 << 15) - 1) overflows.  */
 +#define RE_DUP_MAX (0x7fff)
 +
 +
 +/* POSIX `cflags' bits (i.e., information for `regcomp').  */
 +
 +/* If this bit is set, then use extended regular expression syntax.
 +   If not set, then use basic regular expression syntax.  */
 +#define REG_EXTENDED 1
 +
 +/* If this bit is set, then ignore case when matching.
 +   If not set, then case is significant.  */
 +#define REG_ICASE (REG_EXTENDED << 1)
 +
 +/* If this bit is set, then anchors do not match at newline
 +     characters in the string.
 +   If not set, then anchors do match at newlines.  */
 +#define REG_NEWLINE (REG_ICASE << 1)
 +
 +/* If this bit is set, then report only success or fail in regexec.
 +   If not set, then returns differ between not matching and errors.  */
 +#define REG_NOSUB (REG_NEWLINE << 1)
 +
 +
 +/* POSIX `eflags' bits (i.e., information for regexec).  */
 +
 +/* If this bit is set, then the beginning-of-line operator doesn't match
 +     the beginning of the string (presumably because it's not the
 +     beginning of a line).
 +   If not set, then the beginning-of-line operator does match the
 +     beginning of the string.  */
 +#define REG_NOTBOL 1
 +
 +/* Like REG_NOTBOL, except for the end-of-line.  */
 +#define REG_NOTEOL (1 << 1)
 +
 +
 +/* If any error codes are removed, changed, or added, update the
 +   `re_error_msg' table in regex.c.  */
 +typedef enum
 +{
 +#ifdef _XOPEN_SOURCE
 +  REG_ENOSYS = -1,	/* This will never happen for this implementation.  */
 +#endif
 +
 +  REG_NOERROR = 0,	/* Success.  */
 +  REG_NOMATCH,		/* Didn't find a match (for regexec).  */
 +
 +  /* POSIX regcomp return error codes.  (In the order listed in the
 +     standard.)  */
 +  REG_BADPAT,		/* Invalid pattern.  */
 +  REG_ECOLLATE,		/* Not implemented.  */
 +  REG_ECTYPE,		/* Invalid character class name.  */
 +  REG_EESCAPE,		/* Trailing backslash.  */
 +  REG_ESUBREG,		/* Invalid back reference.  */
 +  REG_EBRACK,		/* Unmatched left bracket.  */
 +  REG_EPAREN,		/* Parenthesis imbalance.  */
 +  REG_EBRACE,		/* Unmatched \{.  */
 +  REG_BADBR,		/* Invalid contents of \{\}.  */
 +  REG_ERANGE,		/* Invalid range end.  */
 +  REG_ESPACE,		/* Ran out of memory.  */
 +  REG_BADRPT,		/* No preceding re for repetition op.  */
 +
 +  /* Error codes we've added.  */
 +  REG_EEND,		/* Premature end.  */
 +  REG_ESIZE,		/* Compiled pattern bigger than 2^16 bytes.  */
 +  REG_ERPAREN,		/* Unmatched ) or \); not returned from regcomp.  */
 +  REG_ERANGEX		/* Range striding over charsets.  */
 +} reg_errcode_t;
 +
 +/* This data structure represents a compiled pattern.  Before calling
 +   the pattern compiler, the fields `buffer', `allocated', `fastmap',
 +   `translate', and `no_sub' can be set.  After the pattern has been
 +   compiled, the `re_nsub' field is available.  All other fields are
 +   private to the regex routines.  */
 +
 +#ifndef RE_TRANSLATE_TYPE
 +# define RE_TRANSLATE_TYPE char *
 +#endif
 +
 +struct re_pattern_buffer
 +{
 +/* [[[begin pattern_buffer]]] */
 +	/* Space that holds the compiled pattern.  It is declared as
 +          `unsigned char *' because its elements are
 +           sometimes used as array indexes.  */
 +  unsigned char *buffer;
 +
 +	/* Number of bytes to which `buffer' points.  */
 +  size_t allocated;
 +
 +	/* Number of bytes actually used in `buffer'.  */
 +  size_t used;
 +
 +        /* Syntax setting with which the pattern was compiled.  */
 +  reg_syntax_t syntax;
 +
 +        /* Pointer to a fastmap, if any, otherwise zero.  re_search uses
 +           the fastmap, if there is one, to skip over impossible
 +           starting points for matches.  */
 +  char *fastmap;
 +
 +        /* Either a translate table to apply to all characters before
 +           comparing them, or zero for no translation.  The translation
 +           is applied to a pattern when it is compiled and to a string
 +           when it is matched.  */
 +  RE_TRANSLATE_TYPE translate;
 +
 +	/* Number of subexpressions found by the compiler.  */
 +  size_t re_nsub;
 +
 +        /* Zero if this pattern cannot match the empty string, one else.
 +           Well, in truth it's used only in `re_search_2', to see
 +           whether or not we should use the fastmap, so we don't set
 +           this absolutely perfectly; see `re_compile_fastmap'.  */
 +  unsigned can_be_null : 1;
 +
 +        /* If REGS_UNALLOCATED, allocate space in the `regs' structure
 +             for `max (RE_NREGS, re_nsub + 1)' groups.
 +           If REGS_REALLOCATE, reallocate space if necessary.
 +           If REGS_FIXED, use what's there.  */
 +#define REGS_UNALLOCATED 0
 +#define REGS_REALLOCATE 1
 +#define REGS_FIXED 2
 +  unsigned regs_allocated : 2;
 +
 +        /* Set to zero when `regex_compile' compiles a pattern; set to one
 +           by `re_compile_fastmap' if it updates the fastmap.  */
 +  unsigned fastmap_accurate : 1;
 +
 +        /* If set, `re_match_2' does not return information about
 +           subexpressions.  */
 +  unsigned no_sub : 1;
 +
 +        /* If set, a beginning-of-line anchor doesn't match at the
 +           beginning of the string.  */
 +  unsigned not_bol : 1;
 +
 +        /* Similarly for an end-of-line anchor.  */
 +  unsigned not_eol : 1;
 +
 +  /* If true, the compilation of the pattern had to look up the syntax table,
 +     so the compiled pattern is only valid for the current syntax table.  */
 +  unsigned used_syntax : 1;
 +
 +#ifdef emacs
 +  /* If true, multi-byte form in the regexp pattern should be
 +     recognized as a multibyte character.  */
 +  unsigned multibyte : 1;
 +
 +  /* If true, multi-byte form in the target of match should be
 +     recognized as a multibyte character.  */
 +  unsigned target_multibyte : 1;
 +
 +  /* Charset of unibyte characters at compiling time. */
 +  int charset_unibyte;
 +#endif
 +
 +/* [[[end pattern_buffer]]] */
 +};
 +
 +typedef struct re_pattern_buffer regex_t;
 +
 +/* Type for byte offsets within the string.  POSIX mandates this to be an int,
 +   but the Open Group has signaled its intention to change the requirement to
 +   be that regoff_t be at least as wide as ptrdiff_t and ssize_t.  Current
 +   gnulib sources also use ssize_t, and we need this for supporting buffers and
 +   strings > 2GB on 64-bit hosts.  */
 +typedef ssize_t regoff_t;
 +
 +
 +/* This is the structure we store register match data in.  See
 +   regex.texinfo for a full description of what registers match.  */
 +struct re_registers
 +{
 +  unsigned num_regs;
 +  regoff_t *start;
 +  regoff_t *end;
 +};
 +
 +
 +/* If `regs_allocated' is REGS_UNALLOCATED in the pattern buffer,
 +   `re_match_2' returns information about at least this many registers
 +   the first time a `regs' structure is passed.  */
 +#ifndef RE_NREGS
 +# define RE_NREGS 30
 +#endif
 +
 +
 +/* POSIX specification for registers.  Aside from the different names than
 +   `re_registers', POSIX uses an array of structures, instead of a
 +   structure of arrays.  */
 +typedef struct
 +{
 +  regoff_t rm_so;  /* Byte offset from string's start to substring's start.  */
 +  regoff_t rm_eo;  /* Byte offset from string's start to substring's end.  */
 +} regmatch_t;
 +
 +/* Declarations for routines.  */
 +
 +/* Sets the current default syntax to SYNTAX, and return the old syntax.
 +   You can also simply assign to the `re_syntax_options' variable.  */
 +extern reg_syntax_t re_set_syntax (reg_syntax_t __syntax);
 +
 +/* Compile the regular expression PATTERN, with length LENGTH
 +   and syntax given by the global `re_syntax_options', into the buffer
 +   BUFFER.  Return NULL if successful, and an error string if not.  */
 +extern const char *re_compile_pattern (const char *__pattern, size_t __length,
 +				       struct re_pattern_buffer *__buffer);
 +
 +
 +/* Compile a fastmap for the compiled pattern in BUFFER; used to
 +   accelerate searches.  Return 0 if successful and -2 if was an
 +   internal error.  */
 +extern int re_compile_fastmap (struct re_pattern_buffer *__buffer);
 +
 +
 +/* Search in the string STRING (with length LENGTH) for the pattern
 +   compiled into BUFFER.  Start searching at position START, for RANGE
 +   characters.  Return the starting position of the match, -1 for no
 +   match, or -2 for an internal error.  Also return register
 +   information in REGS (if REGS and BUFFER->no_sub are nonzero).  */
 +extern regoff_t re_search (struct re_pattern_buffer *__buffer,
 +			   const char *__string, size_t __length,
 +			   ssize_t __start, ssize_t __range,
 +			   struct re_registers *__regs);
 +
 +
 +/* Like `re_search', but search in the concatenation of STRING1 and
 +   STRING2.  Also, stop searching at index START + STOP.  */
 +extern regoff_t re_search_2 (struct re_pattern_buffer *__buffer,
 +			     const char *__string1, size_t __length1,
 +			     const char *__string2, size_t __length2,
 +			     ssize_t __start, ssize_t __range,
 +			     struct re_registers *__regs,
 +			     ssize_t __stop);
 +
 +
 +/* Like `re_search', but return how many characters in STRING the regexp
 +   in BUFFER matched, starting at position START.  */
 +extern regoff_t re_match (struct re_pattern_buffer *__buffer,
 +			  const char *__string, size_t __length,
 +			  ssize_t __start, struct re_registers *__regs);
 +
 +
 +/* Relates to `re_match' as `re_search_2' relates to `re_search'.  */
 +extern regoff_t re_match_2 (struct re_pattern_buffer *__buffer,
 +			    const char *__string1, size_t __length1,
 +			    const char *__string2, size_t __length2,
 +			    ssize_t __start, struct re_registers *__regs,
 +			    ssize_t __stop);
 +
 +
 +/* Set REGS to hold NUM_REGS registers, storing them in STARTS and
 +   ENDS.  Subsequent matches using BUFFER and REGS will use this memory
 +   for recording register information.  STARTS and ENDS must be
 +   allocated with malloc, and must each be at least `NUM_REGS * sizeof
 +   (regoff_t)' bytes long.
 +
 +   If NUM_REGS == 0, then subsequent matches should allocate their own
 +   register data.
 +
 +   Unless this function is called, the first search or match using
 +   PATTERN_BUFFER will allocate its own register data, without
 +   freeing the old data.  */
 +extern void re_set_registers (struct re_pattern_buffer *__buffer,
 +			      struct re_registers *__regs,
 +			      unsigned __num_regs,
 +			      regoff_t *__starts, regoff_t *__ends);
 +
 +#if defined _REGEX_RE_COMP || defined _LIBC
 +# ifndef _CRAY
 +/* 4.2 bsd compatibility.  */
 +extern char *re_comp (const char *);
 +extern int re_exec (const char *);
 +# endif
 +#endif
 +
 +/* GCC 2.95 and later have "__restrict"; C99 compilers have
 +   "restrict", and "configure" may have defined "restrict".
 +   Other compilers use __restrict, __restrict__, and _Restrict, and
 +   'configure' might #define 'restrict' to those words, so pick a
 +   different name.  */
 +#ifndef _Restrict_
 +# if 199901L <= __STDC_VERSION__
 +#  define _Restrict_ restrict
 +# elif 2 < __GNUC__ || (2 == __GNUC__ && 95 <= __GNUC_MINOR__)
 +#  define _Restrict_ __restrict
 +# else
 +#  define _Restrict_
 +# endif
 +#endif
 +/* gcc 3.1 and up support the [restrict] syntax.  Don't trust
 +   sys/cdefs.h's definition of __restrict_arr, though, as it
 +   mishandles gcc -ansi -pedantic.  */
 +#ifndef _Restrict_arr_
 +# if ((199901L <= __STDC_VERSION__					\
 +       || ((3 < __GNUC__ || (3 == __GNUC__ && 1 <= __GNUC_MINOR__))	\
 +	   && !defined __STRICT_ANSI__))					\
 +      && !defined __GNUG__)
 +#  define _Restrict_arr_ _Restrict_
 +# else
 +#  define _Restrict_arr_
 +# endif
 +#endif
 +
 +/* POSIX compatibility.  */
 +extern reg_errcode_t regcomp (regex_t *_Restrict_ __preg,
 +			      const char *_Restrict_ __pattern,
 +			      int __cflags);
 +
 +extern reg_errcode_t regexec (const regex_t *_Restrict_ __preg,
 +			      const char *_Restrict_ __string, size_t __nmatch,
 +			      regmatch_t __pmatch[_Restrict_arr_],
 +			      int __eflags);
 +
 +extern size_t regerror (int __errcode, const regex_t * __preg,
 +			char *__errbuf, size_t __errbuf_size);
 +
 +extern void regfree (regex_t *__preg);
 +
 +
 +#ifdef __cplusplus
 +}
 +#endif	/* C++ */
 +
 +/* For platform which support the ISO C amendment 1 functionality we
 +   support user defined character classes.  */
 +#if WIDE_CHAR_SUPPORT
 +/* Solaris 2.5 has a bug:  must be included before .  */
 +# include 
 +# include 
 +#endif
 +
 +#if WIDE_CHAR_SUPPORT
 +/* The GNU C library provides support for user-defined character classes
 +   and the functions from ISO C amendment 1.  */
 +# ifdef CHARCLASS_NAME_MAX
 +#  define CHAR_CLASS_MAX_LENGTH CHARCLASS_NAME_MAX
 +# else
 +/* This shouldn't happen but some implementation might still have this
 +   problem.  Use a reasonable default value.  */
 +#  define CHAR_CLASS_MAX_LENGTH 256
 +# endif
 +typedef wctype_t re_wctype_t;
 +typedef wchar_t re_wchar_t;
 +# define re_wctype wctype
 +# define re_iswctype iswctype
 +# define re_wctype_to_bit(cc) 0
 +#else
 +# define CHAR_CLASS_MAX_LENGTH  9 /* Namely, `multibyte'.  */
 +# define btowc(c) c
 +
 +/* Character classes.  */
 +typedef enum { RECC_ERROR = 0,
 +	       RECC_ALNUM, RECC_ALPHA, RECC_WORD,
 +	       RECC_GRAPH, RECC_PRINT,
 +	       RECC_LOWER, RECC_UPPER,
 +	       RECC_PUNCT, RECC_CNTRL,
 +	       RECC_DIGIT, RECC_XDIGIT,
 +	       RECC_BLANK, RECC_SPACE,
 +	       RECC_MULTIBYTE, RECC_NONASCII,
 +	       RECC_ASCII, RECC_UNIBYTE
 +} re_wctype_t;
 +
 +extern char re_iswctype (int ch,    re_wctype_t cc);
 +extern re_wctype_t re_wctype (const unsigned char* str);
 +
 +typedef int re_wchar_t;
 +
 +extern void re_set_whitespace_regexp (const char *regexp);
 +
 +#endif /* not WIDE_CHAR_SUPPORT */
 +
 +#endif /* regex.h */
 +
diff --cc test/manual/etags/c-src/etags.c
index 453419897bc,00000000000..e8321f05ff4
mode 100644,000000..100644
--- a/test/manual/etags/c-src/etags.c
+++ b/test/manual/etags/c-src/etags.c
@@@ -1,6563 -1,0 +1,6563 @@@
 +/* Tags file maker to go with GNU Emacs           -*- coding: utf-8 -*-
 +
 +Copyright (C) 1984 The Regents of the University of California
 +
 +Redistribution and use in source and binary forms, with or without
 +modification, are permitted provided that the following conditions are
 +met:
 +1. Redistributions of source code must retain the above copyright
 +   notice, this list of conditions and the following disclaimer.
 +2. Redistributions in binary form must reproduce the above copyright
 +   notice, this list of conditions and the following disclaimer in the
 +   documentation and/or other materials provided with the
 +   distribution.
 +3. Neither the name of the University nor the names of its
 +   contributors may be used to endorse or promote products derived
 +   from this software without specific prior written permission.
 +
 +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS''
 +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
 +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 +PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS
 +BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
 +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 +
 +
- Copyright (C) 1984, 1987-1989, 1993-1995, 1998-2016 Free Software
++Copyright (C) 1984, 1987-1989, 1993-1995, 1998-2017 Free Software
 +Foundation, Inc.
 +
 +This file is not considered part of GNU Emacs.
 +
 +This program is free software: you can redistribute it and/or modify
 +it under the terms of the GNU General Public License as published by
 +the Free Software Foundation, either version 3 of the License, or (at
 +your option) any later version.
 +
 +This program is distributed in the hope that it will be useful,
 +but WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +GNU General Public License for more details.
 +
 +You should have received a copy of the GNU General Public License
 +along with this program.  If not, see .  */
 +
 +
 +/* NB To comply with the above BSD license, copyright information is
 +reproduced in etc/ETAGS.README.  That file should be updated when the
 +above notices are.
 +
 +To the best of our knowledge, this code was originally based on the
 +ctags.c distributed with BSD4.2, which was copyrighted by the
 +University of California, as described above. */
 +
 +
 +/*
 + * Authors:
 + * 1983 Ctags originally by Ken Arnold.
 + * 1984 Fortran added by Jim Kleckner.
 + * 1984 Ed Pelegri-Llopart added C typedefs.
 + * 1985 Emacs TAGS format by Richard Stallman.
 + * 1989 Sam Kendall added C++.
 + * 1992 Joseph B. Wells improved C and C++ parsing.
 + * 1993 Francesco Potortì reorganized C and C++.
 + * 1994 Line-by-line regexp tags by Tom Tromey.
 + * 2001 Nested classes by Francesco Potortì (concept by Mykola Dzyuba).
 + * 2002 #line directives by Francesco Potortì.
 + *
 + * Francesco Potortì  has maintained and improved it since 1993.
 + */
 +
 +/*
 + * If you want to add support for a new language, start by looking at the LUA
 + * language, which is the simplest.  Alternatively, consider distributing etags
 + * together with a configuration file containing regexp definitions for etags.
 + */
 +
 +char pot_etags_version[] = "@(#) pot revision number is 17.38.1.4";
 +
 +#ifdef DEBUG
 +#  undef DEBUG
 +#  define DEBUG true
 +#else
 +#  define DEBUG  false
 +#  define NDEBUG		/* disable assert */
 +#endif
 +
 +#include 
 +
 +#ifndef _GNU_SOURCE
 +# define _GNU_SOURCE 1		/* enables some compiler checks on GNU */
 +#endif
 +
 +/* WIN32_NATIVE is for XEmacs.
 +   MSDOS, WINDOWSNT, DOS_NT are for Emacs. */
 +#ifdef WIN32_NATIVE
 +# undef MSDOS
 +# undef  WINDOWSNT
 +# define WINDOWSNT
 +#endif /* WIN32_NATIVE */
 +
 +#ifdef MSDOS
 +# undef MSDOS
 +# define MSDOS true
 +# include 
 +#else
 +# define MSDOS false
 +#endif /* MSDOS */
 +
 +#ifdef WINDOWSNT
 +# include 
 +# define MAXPATHLEN _MAX_PATH
 +# undef HAVE_NTGUI
 +# undef  DOS_NT
 +# define DOS_NT
 +#endif /* WINDOWSNT */
 +
 +#include 
 +#include 
 +#include 
 +#include 
 +#include 
 +#include 
 +#include 
 +#include 
 +#include 
 +#include 
 +#include 
 +
 +#include 
 +#ifdef NDEBUG
 +# undef  assert			/* some systems have a buggy assert.h */
 +# define assert(x) ((void) 0)
 +#endif
 +
 +#include 
 +#include 
 +
 +/* Define CTAGS to make the program "ctags" compatible with the usual one.
 + Leave it undefined to make the program "etags", which makes emacs-style
 + tag tables and tags typedefs, #defines and struct/union/enum by default. */
 +#ifdef CTAGS
 +# undef  CTAGS
 +# define CTAGS true
 +#else
 +# define CTAGS false
 +#endif
 +
 +#define streq(s,t)	(assert ((s)!=NULL || (t)!=NULL), !strcmp (s, t))
 +#define strcaseeq(s,t)	(assert ((s)!=NULL && (t)!=NULL), !c_strcasecmp (s, t))
 +#define strneq(s,t,n)	(assert ((s)!=NULL || (t)!=NULL), !strncmp (s, t, n))
 +#define strncaseeq(s,t,n) (assert ((s)!=NULL && (t)!=NULL), !c_strncasecmp (s, t, n))
 +
 +#define CHARS 256		/* 2^sizeof(char) */
 +#define CHAR(x)		((unsigned int)(x) & (CHARS - 1))
 +#define	iswhite(c)	(_wht[CHAR (c)]) /* c is white (see white) */
 +#define notinname(c)	(_nin[CHAR (c)]) /* c is not in a name (see nonam) */
 +#define	begtoken(c)	(_btk[CHAR (c)]) /* c can start token (see begtk) */
 +#define	intoken(c)	(_itk[CHAR (c)]) /* c can be in token (see midtk) */
 +#define	endtoken(c)	(_etk[CHAR (c)]) /* c ends tokens (see endtk) */
 +
 +#define ISALNUM(c)	isalnum (CHAR (c))
 +#define ISALPHA(c)	isalpha (CHAR (c))
 +#define ISDIGIT(c)	isdigit (CHAR (c))
 +#define ISLOWER(c)	islower (CHAR (c))
 +
 +#define lowcase(c)	tolower (CHAR (c))
 +
 +
 +/*
 + *	xnew, xrnew -- allocate, reallocate storage
 + *
 + * SYNOPSIS:	Type *xnew (int n, Type);
 + *		void xrnew (OldPointer, int n, Type);
 + */
 +#define xnew(n, Type)      ((Type *) xmalloc ((n) * sizeof (Type)))
 +#define xrnew(op, n, Type) ((op) = (Type *) xrealloc (op, (n) * sizeof (Type)))
 +
 +typedef void Lang_function (FILE *);
 +
 +typedef struct
 +{
 +  const char *suffix;           /* file name suffix for this compressor */
 +  const char *command;		/* takes one arg and decompresses to stdout */
 +} compressor;
 +
 +typedef struct
 +{
 +  const char *name;             /* language name */
 +  const char *help; 		/* detailed help for the language */
 +  Lang_function *function;	/* parse function */
 +  const char **suffixes;        /* name suffixes of this language's files */
 +  const char **filenames;       /* names of this language's files */
 +  const char **interpreters;    /* interpreters for this language */
 +  bool metasource;		/* source used to generate other sources */
 +} language;
 +
 +typedef struct fdesc
 +{
 +  struct fdesc *next;		/* for the linked list */
 +  char *infname;		/* uncompressed input file name */
 +  char *infabsname;		/* absolute uncompressed input file name */
 +  char *infabsdir;		/* absolute dir of input file */
 +  char *taggedfname;		/* file name to write in tagfile */
 +  language *lang;		/* language of file */
 +  char *prop;			/* file properties to write in tagfile */
 +  bool usecharno;		/* etags tags shall contain char number */
 +  bool written;			/* entry written in the tags file */
 +} fdesc;
 +
 +typedef struct node_st
 +{				/* sorting structure */
 +  struct node_st *left, *right;	/* left and right sons */
 +  fdesc *fdp;			/* description of file to whom tag belongs */
 +  char *name; 			/* tag name */
 +  char *regex;			/* search regexp */
 +  bool valid;			/* write this tag on the tag file */
 +  bool is_func;			/* function tag: use regexp in CTAGS mode */
 +  bool been_warned;		/* warning already given for duplicated tag */
 +  int lno;			/* line number tag is on */
 +  long cno;			/* character number line starts on */
 +} node;
 +
 +/*
 + * A `linebuffer' is a structure which holds a line of text.
 + * `readline_internal' reads a line from a stream into a linebuffer
 + * and works regardless of the length of the line.
 + * SIZE is the size of BUFFER, LEN is the length of the string in
 + * BUFFER after readline reads it.
 + */
 +typedef struct
 +{
 +  long size;
 +  int len;
 +  char *buffer;
 +} linebuffer;
 +
 +/* Used to support mixing of --lang and file names. */
 +typedef struct
 +{
 +  enum {
 +    at_language,		/* a language specification */
 +    at_regexp,			/* a regular expression */
 +    at_filename,		/* a file name */
 +    at_stdin,			/* read from stdin here */
 +    at_end			/* stop parsing the list */
 +  } arg_type;			/* argument type */
 +  language *lang;		/* language associated with the argument */
 +  char *what;			/* the argument itself */
 +} argument;
 +
 +/* Structure defining a regular expression. */
 +typedef struct regexp
 +{
 +  struct regexp *p_next;	/* pointer to next in list */
 +  language *lang;		/* if set, use only for this language */
 +  char *pattern;		/* the regexp pattern */
 +  char *name;			/* tag name */
 +  struct re_pattern_buffer *pat; /* the compiled pattern */
 +  struct re_registers regs;	/* re registers */
 +  bool error_signaled;		/* already signaled for this regexp */
 +  bool force_explicit_name;	/* do not allow implicit tag name */
 +  bool ignore_case;		/* ignore case when matching */
 +  bool multi_line;		/* do a multi-line match on the whole file */
 +} regexp;
 +
 +
 +/* Many compilers barf on this:
 +	Lang_function Ada_funcs;
 +   so let's write it this way */
 +static void Ada_funcs (FILE *);
 +static void Asm_labels (FILE *);
 +static void C_entries (int c_ext, FILE *);
 +static void default_C_entries (FILE *);
 +static void plain_C_entries (FILE *);
 +static void Cjava_entries (FILE *);
 +static void Cobol_paragraphs (FILE *);
 +static void Cplusplus_entries (FILE *);
 +static void Cstar_entries (FILE *);
 +static void Erlang_functions (FILE *);
 +static void Forth_words (FILE *);
 +static void Fortran_functions (FILE *);
 +static void HTML_labels (FILE *);
 +static void Lisp_functions (FILE *);
 +static void Lua_functions (FILE *);
 +static void Makefile_targets (FILE *);
 +static void Pascal_functions (FILE *);
 +static void Perl_functions (FILE *);
 +static void PHP_functions (FILE *);
 +static void PS_functions (FILE *);
 +static void Prolog_functions (FILE *);
 +static void Python_functions (FILE *);
 +static void Scheme_functions (FILE *);
 +static void TeX_commands (FILE *);
 +static void Texinfo_nodes (FILE *);
 +static void Yacc_entries (FILE *);
 +static void just_read_file (FILE *);
 +
 +static language *get_language_from_langname (const char *);
 +static void readline (linebuffer *, FILE *);
 +static long readline_internal (linebuffer *, FILE *);
 +static bool nocase_tail (const char *);
 +static void get_tag (char *, char **);
 +
 +static void analyze_regex (char *);
 +static void free_regexps (void);
 +static void regex_tag_multiline (void);
 +static void error (const char *, ...) ATTRIBUTE_FORMAT_PRINTF (1, 2);
 +static _Noreturn void suggest_asking_for_help (void);
 +_Noreturn void fatal (const char *, const char *);
 +static _Noreturn void pfatal (const char *);
 +static void add_node (node *, node **);
 +
 +static void init (void);
 +static void process_file_name (char *, language *);
 +static void process_file (FILE *, char *, language *);
 +static void find_entries (FILE *);
 +static void free_tree (node *);
 +static void free_fdesc (fdesc *);
 +static void pfnote (char *, bool, char *, int, int, long);
 +static void invalidate_nodes (fdesc *, node **);
 +static void put_entries (node *);
 +
 +static char *concat (const char *, const char *, const char *);
 +static char *skip_spaces (char *);
 +static char *skip_non_spaces (char *);
 +static char *skip_name (char *);
 +static char *savenstr (const char *, int);
 +static char *savestr (const char *);
 +static char *etags_getcwd (void);
 +static char *relative_filename (char *, char *);
 +static char *absolute_filename (char *, char *);
 +static char *absolute_dirname (char *, char *);
 +static bool filename_is_absolute (char *f);
 +static void canonicalize_filename (char *);
 +static void linebuffer_init (linebuffer *);
 +static void linebuffer_setlen (linebuffer *, int);
 +static void *xmalloc (size_t);
 +static void *xrealloc (void *, size_t);
 +
 +
 +static char searchar = '/';	/* use /.../ searches */
 +
 +static char *tagfile;		/* output file */
 +static char *progname;		/* name this program was invoked with */
 +static char *cwd;		/* current working directory */
 +static char *tagfiledir;	/* directory of tagfile */
 +static FILE *tagf;		/* ioptr for tags file */
 +static ptrdiff_t whatlen_max;	/* maximum length of any 'what' member */
 +
 +static fdesc *fdhead;		/* head of file description list */
 +static fdesc *curfdp;		/* current file description */
 +static int lineno;		/* line number of current line */
 +static long charno;		/* current character number */
 +static long linecharno;		/* charno of start of current line */
 +static char *dbp;		/* pointer to start of current tag */
 +
 +static const int invalidcharno = -1;
 +
 +static node *nodehead;		/* the head of the binary tree of tags */
 +static node *last_node;		/* the last node created */
 +
 +static linebuffer lb;		/* the current line */
 +static linebuffer filebuf;	/* a buffer containing the whole file */
 +static linebuffer token_name;	/* a buffer containing a tag name */
 +
 +/* boolean "functions" (see init)	*/
 +static bool _wht[CHARS], _nin[CHARS], _itk[CHARS], _btk[CHARS], _etk[CHARS];
 +static const char
 +  /* white chars */
 +  *white = " \f\t\n\r\v",
 +  /* not in a name */
 +  *nonam = " \f\t\n\r()=,;",	/* look at make_tag before modifying! */
 +  /* token ending chars */
 +  *endtk = " \t\n\r\"'#()[]{}=-+%*/&|^~!<>;,.:?",
 +  /* token starting chars */
 +  *begtk = "ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz$~@",
 +  /* valid in-token chars */
 +  *midtk = "ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz$0123456789";
 +
 +static bool append_to_tagfile;	/* -a: append to tags */
 +/* The next five default to true in C and derived languages.  */
 +static bool typedefs;		/* -t: create tags for C and Ada typedefs */
 +static bool typedefs_or_cplusplus; /* -T: create tags for C typedefs, level */
 +				/* 0 struct/enum/union decls, and C++ */
 +				/* member functions. */
 +static bool constantypedefs;	/* -d: create tags for C #define, enum */
 +				/* constants and variables. */
 +				/* -D: opposite of -d.  Default under ctags. */
 +static int globals;		/* create tags for global variables */
 +static int members;		/* create tags for C member variables */
 +static int declarations;	/* --declarations: tag them and extern in C&Co*/
 +static int no_line_directive;	/* ignore #line directives (undocumented) */
 +static int no_duplicates;	/* no duplicate tags for ctags (undocumented) */
 +static bool update;		/* -u: update tags */
 +static bool vgrind_style;	/* -v: create vgrind style index output */
 +static bool no_warnings;	/* -w: suppress warnings (undocumented) */
 +static bool cxref_style;	/* -x: create cxref style output */
 +static bool cplusplus;		/* .[hc] means C++, not C (undocumented) */
 +static bool ignoreindent;	/* -I: ignore indentation in C */
 +static int packages_only;	/* --packages-only: in Ada, only tag packages*/
 +
 +/* STDIN is defined in LynxOS system headers */
 +#ifdef STDIN
 +# undef STDIN
 +#endif
 +
 +#define STDIN 0x1001		/* returned by getopt_long on --parse-stdin */
 +static bool parsing_stdin;	/* --parse-stdin used */
 +
 +static regexp *p_head;		/* list of all regexps */
 +static bool need_filebuf;	/* some regexes are multi-line */
 +
 +static struct option longopts[] =
 +{
 +  { "append",             no_argument,       NULL,               'a'   },
 +  { "packages-only",      no_argument,       &packages_only,     1     },
 +  { "c++",                no_argument,       NULL,               'C'   },
 +  { "declarations",       no_argument,       &declarations,      1     },
 +  { "no-line-directive",  no_argument,       &no_line_directive, 1     },
 +  { "no-duplicates",      no_argument,       &no_duplicates,     1     },
 +  { "help",               no_argument,       NULL,               'h'   },
 +  { "help",               no_argument,       NULL,               'H'   },
 +  { "ignore-indentation", no_argument,       NULL,               'I'   },
 +  { "language",           required_argument, NULL,               'l'   },
 +  { "members",            no_argument,       &members,           1     },
 +  { "no-members",         no_argument,       &members,           0     },
 +  { "output",             required_argument, NULL,               'o'   },
 +  { "regex",              required_argument, NULL,               'r'   },
 +  { "no-regex",           no_argument,       NULL,               'R'   },
 +  { "ignore-case-regex",  required_argument, NULL,               'c'   },
 +  { "parse-stdin",        required_argument, NULL,               STDIN },
 +  { "version",            no_argument,       NULL,               'V'   },
 +
 +#if CTAGS /* Ctags options */
 +  { "backward-search",    no_argument,       NULL,               'B'   },
 +  { "cxref",              no_argument,       NULL,               'x'   },
 +  { "defines",            no_argument,       NULL,               'd'   },
 +  { "globals",            no_argument,       &globals,           1     },
 +  { "typedefs",           no_argument,       NULL,               't'   },
 +  { "typedefs-and-c++",   no_argument,       NULL,               'T'   },
 +  { "update",             no_argument,       NULL,               'u'   },
 +  { "vgrind",             no_argument,       NULL,               'v'   },
 +  { "no-warn",            no_argument,       NULL,               'w'   },
 +
 +#else /* Etags options */
 +  { "no-defines",         no_argument,       NULL,               'D'   },
 +  { "no-globals",         no_argument,       &globals,           0     },
 +  { "include",            required_argument, NULL,               'i'   },
 +#endif
 +  { NULL }
 +};
 +
 +static compressor compressors[] =
 +{
 +  { "z", "gzip -d -c"},
 +  { "Z", "gzip -d -c"},
 +  { "gz", "gzip -d -c"},
 +  { "GZ", "gzip -d -c"},
 +  { "bz2", "bzip2 -d -c" },
 +  { "xz", "xz -d -c" },
 +  { NULL }
 +};
 +
 +/*
 + * Language stuff.
 + */
 +
 +/* Ada code */
 +static const char *Ada_suffixes [] =
 +  { "ads", "adb", "ada", NULL };
 +static const char Ada_help [] =
 +"In Ada code, functions, procedures, packages, tasks and types are\n\
 +tags.  Use the `--packages-only' option to create tags for\n\
 +packages only.\n\
 +Ada tag names have suffixes indicating the type of entity:\n\
 +	Entity type:	Qualifier:\n\
 +	------------	----------\n\
 +	function	/f\n\
 +	procedure	/p\n\
 +	package spec	/s\n\
 +	package body	/b\n\
 +	type		/t\n\
 +	task		/k\n\
 +Thus, `M-x find-tag  bidule/b ' will go directly to the\n\
 +body of the package `bidule', while `M-x find-tag  bidule '\n\
 +will just search for any tag `bidule'.";
 +
 +/* Assembly code */
 +static const char *Asm_suffixes [] =
 +  { "a",	/* Unix assembler */
 +    "asm", /* Microcontroller assembly */
 +    "def", /* BSO/Tasking definition includes  */
 +    "inc", /* Microcontroller include files */
 +    "ins", /* Microcontroller include files */
 +    "s", "sa", /* Unix assembler */
 +    "S",   /* cpp-processed Unix assembler */
 +    "src", /* BSO/Tasking C compiler output */
 +    NULL
 +  };
 +static const char Asm_help [] =
 +"In assembler code, labels appearing at the beginning of a line,\n\
 +followed by a colon, are tags.";
 +
 +
 +/* Note that .c and .h can be considered C++, if the --c++ flag was
 +   given, or if the `class' or `template' keywords are met inside the file.
 +   That is why default_C_entries is called for these. */
 +static const char *default_C_suffixes [] =
 +  { "c", "h", NULL };
 +#if CTAGS				/* C help for Ctags */
 +static const char default_C_help [] =
 +"In C code, any C function is a tag.  Use -t to tag typedefs.\n\
 +Use -T to tag definitions of `struct', `union' and `enum'.\n\
 +Use -d to tag `#define' macro definitions and `enum' constants.\n\
 +Use --globals to tag global variables.\n\
 +You can tag function declarations and external variables by\n\
 +using `--declarations', and struct members by using `--members'.";
 +#else					/* C help for Etags */
 +static const char default_C_help [] =
 +"In C code, any C function or typedef is a tag, and so are\n\
 +definitions of `struct', `union' and `enum'.  `#define' macro\n\
 +definitions and `enum' constants are tags unless you specify\n\
 +`--no-defines'.  Global variables are tags unless you specify\n\
 +`--no-globals' and so are struct members unless you specify\n\
 +`--no-members'.  Use of `--no-globals', `--no-defines' and\n\
 +`--no-members' can make the tags table file much smaller.\n\
 +You can tag function declarations and external variables by\n\
 +using `--declarations'.";
 +#endif	/* C help for Ctags and Etags */
 +
 +static const char *Cplusplus_suffixes [] =
 +  { "C", "c++", "cc", "cpp", "cxx", "H", "h++", "hh", "hpp", "hxx",
 +    "M",			/* Objective C++ */
 +    "pdb",			/* PostScript with C syntax */
 +    NULL };
 +static const char Cplusplus_help [] =
 +"In C++ code, all the tag constructs of C code are tagged.  (Use\n\
 +--help --lang=c --lang=c++ for full help.)\n\
 +In addition to C tags, member functions are also recognized.  Member\n\
 +variables are recognized unless you use the `--no-members' option.\n\
 +Tags for variables and functions in classes are named `CLASS::VARIABLE'\n\
 +and `CLASS::FUNCTION'.  `operator' definitions have tag names like\n\
 +`operator+'.";
 +
 +static const char *Cjava_suffixes [] =
 +  { "java", NULL };
 +static char Cjava_help [] =
 +"In Java code, all the tags constructs of C and C++ code are\n\
 +tagged.  (Use --help --lang=c --lang=c++ --lang=java for full help.)";
 +
 +
 +static const char *Cobol_suffixes [] =
 +  { "COB", "cob", NULL };
 +static char Cobol_help [] =
 +"In Cobol code, tags are paragraph names; that is, any word\n\
 +starting in column 8 and followed by a period.";
 +
 +static const char *Cstar_suffixes [] =
 +  { "cs", "hs", NULL };
 +
 +static const char *Erlang_suffixes [] =
 +  { "erl", "hrl", NULL };
 +static const char Erlang_help [] =
 +"In Erlang code, the tags are the functions, records and macros\n\
 +defined in the file.";
 +
 +const char *Forth_suffixes [] =
 +  { "fth", "tok", NULL };
 +static const char Forth_help [] =
 +"In Forth code, tags are words defined by `:',\n\
 +constant, code, create, defer, value, variable, buffer:, field.";
 +
 +static const char *Fortran_suffixes [] =
 +  { "F", "f", "f90", "for", NULL };
 +static const char Fortran_help [] =
 +"In Fortran code, functions, subroutines and block data are tags.";
 +
 +static const char *HTML_suffixes [] =
 +  { "htm", "html", "shtml", NULL };
 +static const char HTML_help [] =
 +"In HTML input files, the tags are the `title' and the `h1', `h2',\n\
 +`h3' headers.  Also, tags are `name=' in anchors and all\n\
 +occurrences of `id='.";
 +
 +static const char *Lisp_suffixes [] =
 +  { "cl", "clisp", "el", "l", "lisp", "LSP", "lsp", "ml", NULL };
 +static const char Lisp_help [] =
 +"In Lisp code, any function defined with `defun', any variable\n\
 +defined with `defvar' or `defconst', and in general the first\n\
 +argument of any expression that starts with `(def' in column zero\n\
 +is a tag.\n\
 +The `--declarations' option tags \"(defvar foo)\" constructs too.";
 +
 +static const char *Lua_suffixes [] =
 +  { "lua", "LUA", NULL };
 +static const char Lua_help [] =
 +"In Lua scripts, all functions are tags.";
 +
 +static const char *Makefile_filenames [] =
 +  { "Makefile", "makefile", "GNUMakefile", "Makefile.in", "Makefile.am", NULL};
 +static const char Makefile_help [] =
 +"In makefiles, targets are tags; additionally, variables are tags\n\
 +unless you specify `--no-globals'.";
 +
 +static const char *Objc_suffixes [] =
 +  { "lm",			/* Objective lex file */
 +    "m",			/* Objective C file */
 +     NULL };
 +static const char Objc_help [] =
 +"In Objective C code, tags include Objective C definitions for classes,\n\
 +class categories, methods and protocols.  Tags for variables and\n\
 +functions in classes are named `CLASS::VARIABLE' and `CLASS::FUNCTION'.\
 +\n(Use --help --lang=c --lang=objc --lang=java for full help.)";
 +
 +static const char *Pascal_suffixes [] =
 +  { "p", "pas", NULL };
 +static const char Pascal_help [] =
 +"In Pascal code, the tags are the functions and procedures defined\n\
 +in the file.";
 +/* " // this is for working around an Emacs highlighting bug... */
 +
 +static const char *Perl_suffixes [] =
 +  { "pl", "pm", NULL };
 +static const char *Perl_interpreters [] =
 +  { "perl", "@PERL@", NULL };
 +static const char Perl_help [] =
 +"In Perl code, the tags are the packages, subroutines and variables\n\
 +defined by the `package', `sub', `my' and `local' keywords.  Use\n\
 +`--globals' if you want to tag global variables.  Tags for\n\
 +subroutines are named `PACKAGE::SUB'.  The name for subroutines\n\
 +defined in the default package is `main::SUB'.";
 +
 +static const char *PHP_suffixes [] =
 +  { "php", "php3", "php4", NULL };
 +static const char PHP_help [] =
 +"In PHP code, tags are functions, classes and defines.  Unless you use\n\
 +the `--no-members' option, vars are tags too.";
 +
 +static const char *plain_C_suffixes [] =
 +  { "pc",			/* Pro*C file */
 +     NULL };
 +
 +static const char *PS_suffixes [] =
 +  { "ps", "psw", NULL };	/* .psw is for PSWrap */
 +static const char PS_help [] =
 +"In PostScript code, the tags are the functions.";
 +
 +static const char *Prolog_suffixes [] =
 +  { "prolog", NULL };
 +static const char Prolog_help [] =
 +"In Prolog code, tags are predicates and rules at the beginning of\n\
 +line.";
 +
 +static const char *Python_suffixes [] =
 +  { "py", NULL };
 +static const char Python_help [] =
 +"In Python code, `def' or `class' at the beginning of a line\n\
 +generate a tag.";
 +
 +/* Can't do the `SCM' or `scm' prefix with a version number. */
 +static const char *Scheme_suffixes [] =
 +  { "oak", "sch", "scheme", "SCM", "scm", "SM", "sm", "ss", "t", NULL };
 +static const char Scheme_help [] =
 +"In Scheme code, tags include anything defined with `def' or with a\n\
 +construct whose name starts with `def'.  They also include\n\
 +variables set with `set!' at top level in the file.";
 +
 +static const char *TeX_suffixes [] =
 +  { "bib", "clo", "cls", "ltx", "sty", "TeX", "tex", NULL };
 +static const char TeX_help [] =
 +"In LaTeX text, the argument of any of the commands `\\chapter',\n\
 +`\\section', `\\subsection', `\\subsubsection', `\\eqno', `\\label',\n\
 +`\\ref', `\\cite', `\\bibitem', `\\part', `\\appendix', `\\entry',\n\
 +`\\index', `\\def', `\\newcommand', `\\renewcommand',\n\
 +`\\newenvironment' or `\\renewenvironment' is a tag.\n\
 +\n\
 +Other commands can be specified by setting the environment variable\n\
 +`TEXTAGS' to a colon-separated list like, for example,\n\
 +     TEXTAGS=\"mycommand:myothercommand\".";
 +
 +
 +static const char *Texinfo_suffixes [] =
 +  { "texi", "texinfo", "txi", NULL };
 +static const char Texinfo_help [] =
 +"for texinfo files, lines starting with @node are tagged.";
 +
 +static const char *Yacc_suffixes [] =
 +  { "y", "y++", "ym", "yxx", "yy", NULL }; /* .ym is Objective yacc file */
 +static const char Yacc_help [] =
 +"In Bison or Yacc input files, each rule defines as a tag the\n\
 +nonterminal it constructs.  The portions of the file that contain\n\
 +C code are parsed as C code (use --help --lang=c --lang=yacc\n\
 +for full help).";
 +
 +static const char auto_help [] =
 +"`auto' is not a real language, it indicates to use\n\
 +a default language for files base on file name suffix and file contents.";
 +
 +static const char none_help [] =
 +"`none' is not a real language, it indicates to only do\n\
 +regexp processing on files.";
 +
 +static const char no_lang_help [] =
 +"No detailed help available for this language.";
 +
 +
 +/*
 + * Table of languages.
 + *
 + * It is ok for a given function to be listed under more than one
 + * name.  I just didn't.
 + */
 +
 +static language lang_names [] =
 +{
 +  { "ada",       Ada_help,       Ada_funcs,         Ada_suffixes       },
 +  { "asm",       Asm_help,       Asm_labels,        Asm_suffixes       },
 +  { "c",         default_C_help, default_C_entries, default_C_suffixes },
 +  { "c++",       Cplusplus_help, Cplusplus_entries, Cplusplus_suffixes },
 +  { "c*",        no_lang_help,   Cstar_entries,     Cstar_suffixes     },
 +  { "cobol",     Cobol_help,     Cobol_paragraphs,  Cobol_suffixes     },
 +  { "erlang",    Erlang_help,    Erlang_functions,  Erlang_suffixes    },
 +  { "forth",     Forth_help,     Forth_words,       Forth_suffixes     },
 +  { "fortran",   Fortran_help,   Fortran_functions, Fortran_suffixes   },
 +  { "html",      HTML_help,      HTML_labels,       HTML_suffixes      },
 +  { "java",      Cjava_help,     Cjava_entries,     Cjava_suffixes     },
 +  { "lisp",      Lisp_help,      Lisp_functions,    Lisp_suffixes      },
 +  { "lua",       Lua_help,       Lua_functions,     Lua_suffixes       },
 +  { "makefile",  Makefile_help,Makefile_targets,NULL,Makefile_filenames},
 +  { "objc",      Objc_help,      plain_C_entries,   Objc_suffixes      },
 +  { "pascal",    Pascal_help,    Pascal_functions,  Pascal_suffixes    },
 +  { "perl",Perl_help,Perl_functions,Perl_suffixes,NULL,Perl_interpreters},
 +  { "php",       PHP_help,       PHP_functions,     PHP_suffixes       },
 +  { "postscript",PS_help,        PS_functions,      PS_suffixes        },
 +  { "proc",      no_lang_help,   plain_C_entries,   plain_C_suffixes   },
 +  { "prolog",    Prolog_help,    Prolog_functions,  Prolog_suffixes    },
 +  { "python",    Python_help,    Python_functions,  Python_suffixes    },
 +  { "scheme",    Scheme_help,    Scheme_functions,  Scheme_suffixes    },
 +  { "tex",       TeX_help,       TeX_commands,      TeX_suffixes       },
 +  { "texinfo",   Texinfo_help,   Texinfo_nodes,     Texinfo_suffixes   },
 +  { "yacc",      Yacc_help,Yacc_entries,Yacc_suffixes,NULL,NULL,true},
 +  { "auto",      auto_help },                      /* default guessing scheme */
 +  { "none",      none_help,      just_read_file }, /* regexp matching only */
 +  { NULL }                /* end of list */
 +};
 +
 +
 +static void
 +print_language_names (void)
 +{
 +  language *lang;
 +  const char **name, **ext;
 +
 +  puts ("\nThese are the currently supported languages, along with the\n\
 +default file names and dot suffixes:");
 +  for (lang = lang_names; lang->name != NULL; lang++)
 +    {
 +      printf ("  %-*s", 10, lang->name);
 +      if (lang->filenames != NULL)
 +	for (name = lang->filenames; *name != NULL; name++)
 +	  printf (" %s", *name);
 +      if (lang->suffixes != NULL)
 +	for (ext = lang->suffixes; *ext != NULL; ext++)
 +	  printf (" .%s", *ext);
 +      puts ("");
 +    }
 +  puts ("where `auto' means use default language for files based on file\n\
 +name suffix, and `none' means only do regexp processing on files.\n\
 +If no language is specified and no matching suffix is found,\n\
 +the first line of the file is read for a sharp-bang (#!) sequence\n\
 +followed by the name of an interpreter.  If no such sequence is found,\n\
 +Fortran is tried first; if no tags are found, C is tried next.\n\
 +When parsing any C file, a \"class\" or \"template\" keyword\n\
 +switches to C++.");
 +  puts ("Compressed files are supported using gzip, bzip2, and xz.\n\
 +\n\
 +For detailed help on a given language use, for example,\n\
 +etags --help --lang=ada.");
 +}
 +
 +#ifndef EMACS_NAME
 +# define EMACS_NAME "standalone"
 +#endif
 +#ifndef VERSION
 +# define VERSION "17.38.1.4"
 +#endif
 +static _Noreturn void
 +print_version (void)
 +{
 +  char emacs_copyright[] = COPYRIGHT;
 +
 +  printf ("%s (%s %s)\n", (CTAGS) ? "ctags" : "etags", EMACS_NAME, VERSION);
 +  puts (emacs_copyright);
 +  puts ("This program is distributed under the terms in ETAGS.README");
 +
 +  exit (EXIT_SUCCESS);
 +}
 +
 +#ifndef PRINT_UNDOCUMENTED_OPTIONS_HELP
 +# define PRINT_UNDOCUMENTED_OPTIONS_HELP false
 +#endif
 +
 +static _Noreturn void
 +print_help (argument *argbuffer)
 +{
 +  bool help_for_lang = false;
 +
 +  for (; argbuffer->arg_type != at_end; argbuffer++)
 +    if (argbuffer->arg_type == at_language)
 +      {
 +	if (help_for_lang)
 +	  puts ("");
 +	puts (argbuffer->lang->help);
 +	help_for_lang = true;
 +      }
 +
 +  if (help_for_lang)
 +    exit (EXIT_SUCCESS);
 +
 +  printf ("Usage: %s [options] [[regex-option ...] file-name] ...\n\
 +\n\
 +These are the options accepted by %s.\n", progname, progname);
 +  puts ("You may use unambiguous abbreviations for the long option names.");
 +  puts ("  A - as file name means read names from stdin (one per line).\n\
 +Absolute names are stored in the output file as they are.\n\
 +Relative ones are stored relative to the output file's directory.\n");
 +
 +  puts ("-a, --append\n\
 +        Append tag entries to existing tags file.");
 +
 +  puts ("--packages-only\n\
 +        For Ada files, only generate tags for packages.");
 +
 +  if (CTAGS)
 +    puts ("-B, --backward-search\n\
 +        Write the search commands for the tag entries using '?', the\n\
 +        backward-search command instead of '/', the forward-search command.");
 +
 +  /* This option is mostly obsolete, because etags can now automatically
 +     detect C++.  Retained for backward compatibility and for debugging and
 +     experimentation.  In principle, we could want to tag as C++ even
 +     before any "class" or "template" keyword.
 +  puts ("-C, --c++\n\
 +        Treat files whose name suffix defaults to C language as C++ files.");
 +  */
 +
 +  puts ("--declarations\n\
 +	In C and derived languages, create tags for function declarations,");
 +  if (CTAGS)
 +    puts ("\tand create tags for extern variables if --globals is used.");
 +  else
 +    puts
 +      ("\tand create tags for extern variables unless --no-globals is used.");
 +
 +  if (CTAGS)
 +    puts ("-d, --defines\n\
 +        Create tag entries for C #define constants and enum constants, too.");
 +  else
 +    puts ("-D, --no-defines\n\
 +        Don't create tag entries for C #define constants and enum constants.\n\
 +	This makes the tags file smaller.");
 +
 +  if (!CTAGS)
 +    puts ("-i FILE, --include=FILE\n\
 +        Include a note in tag file indicating that, when searching for\n\
 +        a tag, one should also consult the tags file FILE after\n\
 +        checking the current file.");
 +
 +  puts ("-l LANG, --language=LANG\n\
 +        Force the following files to be considered as written in the\n\
 +	named language up to the next --language=LANG option.");
 +
 +  if (CTAGS)
 +    puts ("--globals\n\
 +	Create tag entries for global variables in some languages.");
 +  else
 +    puts ("--no-globals\n\
 +	Do not create tag entries for global variables in some\n\
 +	languages.  This makes the tags file smaller.");
 +
 +  if (PRINT_UNDOCUMENTED_OPTIONS_HELP)
 +    puts ("--no-line-directive\n\
 +        Ignore #line preprocessor directives in C and derived languages.");
 +
 +  if (CTAGS)
 +    puts ("--members\n\
 +	Create tag entries for members of structures in some languages.");
 +  else
 +    puts ("--no-members\n\
 +	Do not create tag entries for members of structures\n\
 +	in some languages.");
 +
 +  puts ("-r REGEXP, --regex=REGEXP or --regex=@regexfile\n\
 +        Make a tag for each line matching a regular expression pattern\n\
 +	in the following files.  {LANGUAGE}REGEXP uses REGEXP for LANGUAGE\n\
 +	files only.  REGEXFILE is a file containing one REGEXP per line.\n\
 +	REGEXP takes the form /TAGREGEXP/TAGNAME/MODS, where TAGNAME/ is\n\
 +	optional.  The TAGREGEXP pattern is anchored (as if preceded by ^).");
 +  puts ("	If TAGNAME/ is present, the tags created are named.\n\
 +	For example Tcl named tags can be created with:\n\
 +	  --regex=\"/proc[ \\t]+\\([^ \\t]+\\)/\\1/.\".\n\
 +	MODS are optional one-letter modifiers: `i' means to ignore case,\n\
 +	`m' means to allow multi-line matches, `s' implies `m' and\n\
 +	causes dot to match any character, including newline.");
 +
 +  puts ("-R, --no-regex\n\
 +        Don't create tags from regexps for the following files.");
 +
 +  puts ("-I, --ignore-indentation\n\
 +        In C and C++ do not assume that a closing brace in the first\n\
 +        column is the final brace of a function or structure definition.");
 +
 +  puts ("-o FILE, --output=FILE\n\
 +        Write the tags to FILE.");
 +
 +  puts ("--parse-stdin=NAME\n\
 +        Read from standard input and record tags as belonging to file NAME.");
 +
 +  if (CTAGS)
 +    {
 +      puts ("-t, --typedefs\n\
 +        Generate tag entries for C and Ada typedefs.");
 +      puts ("-T, --typedefs-and-c++\n\
 +        Generate tag entries for C typedefs, C struct/enum/union tags,\n\
 +        and C++ member functions.");
 +    }
 +
 +  if (CTAGS)
 +    puts ("-u, --update\n\
 +        Update the tag entries for the given files, leaving tag\n\
 +        entries for other files in place.  Currently, this is\n\
 +        implemented by deleting the existing entries for the given\n\
 +        files and then rewriting the new entries at the end of the\n\
 +        tags file.  It is often faster to simply rebuild the entire\n\
 +        tag file than to use this.");
 +
 +  if (CTAGS)
 +    {
 +      puts ("-v, --vgrind\n\
 +        Print on the standard output an index of items intended for\n\
 +        human consumption, similar to the output of vgrind.  The index\n\
 +        is sorted, and gives the page number of each item.");
 +
 +      if (PRINT_UNDOCUMENTED_OPTIONS_HELP)
 +	puts ("-w, --no-duplicates\n\
 +        Do not create duplicate tag entries, for compatibility with\n\
 +	traditional ctags.");
 +
 +      if (PRINT_UNDOCUMENTED_OPTIONS_HELP)
 +	puts ("-w, --no-warn\n\
 +        Suppress warning messages about duplicate tag entries.");
 +
 +      puts ("-x, --cxref\n\
 +        Like --vgrind, but in the style of cxref, rather than vgrind.\n\
 +        The output uses line numbers instead of page numbers, but\n\
 +        beyond that the differences are cosmetic; try both to see\n\
 +        which you like.");
 +    }
 +
 +  puts ("-V, --version\n\
 +        Print the version of the program.\n\
 +-h, --help\n\
 +        Print this help message.\n\
 +        Followed by one or more `--language' options prints detailed\n\
 +        help about tag generation for the specified languages.");
 +
 +  print_language_names ();
 +
 +  puts ("");
 +  puts ("Report bugs to bug-gnu-emacs@gnu.org");
 +
 +  exit (EXIT_SUCCESS);
 +}
 +
 +
 +int
 +main (int argc, char **argv)
 +{
 +  int i;
 +  unsigned int nincluded_files;
 +  char **included_files;
 +  argument *argbuffer;
 +  int current_arg, file_count;
 +  linebuffer filename_lb;
 +  bool help_asked = false;
 +  ptrdiff_t len;
 +  char *optstring;
 +  int opt;
 +
 +  progname = argv[0];
 +  nincluded_files = 0;
 +  included_files = xnew (argc, char *);
 +  current_arg = 0;
 +  file_count = 0;
 +
 +  /* Allocate enough no matter what happens.  Overkill, but each one
 +     is small. */
 +  argbuffer = xnew (argc, argument);
 +
 +  /*
 +   * Always find typedefs and structure tags.
 +   * Also default to find macro constants, enum constants, struct
 +   * members and global variables.  Do it for both etags and ctags.
 +   */
 +  typedefs = typedefs_or_cplusplus = constantypedefs = true;
 +  globals = members = true;
 +
 +  /* When the optstring begins with a '-' getopt_long does not rearrange the
 +     non-options arguments to be at the end, but leaves them alone. */
 +  optstring = concat ("-ac:Cf:Il:o:r:RSVhH",
 +		      (CTAGS) ? "BxdtTuvw" : "Di:",
 +		      "");
 +
 +  while ((opt = getopt_long (argc, argv, optstring, longopts, NULL)) != EOF)
 +    switch (opt)
 +      {
 +      case 0:
 +	/* If getopt returns 0, then it has already processed a
 +	   long-named option.  We should do nothing.  */
 +	break;
 +
 +      case 1:
 +	/* This means that a file name has been seen.  Record it. */
 +	argbuffer[current_arg].arg_type = at_filename;
 +	argbuffer[current_arg].what     = optarg;
 +	len = strlen (optarg);
 +	if (whatlen_max < len)
 +	  whatlen_max = len;
 +	++current_arg;
 +	++file_count;
 +	break;
 +
 +      case STDIN:
 +	/* Parse standard input.  Idea by Vivek . */
 +	argbuffer[current_arg].arg_type = at_stdin;
 +	argbuffer[current_arg].what     = optarg;
 +	len = strlen (optarg);
 +	if (whatlen_max < len)
 +	  whatlen_max = len;
 +	++current_arg;
 +	++file_count;
 +	if (parsing_stdin)
 +	  fatal ("cannot parse standard input more than once", (char *)NULL);
 +	parsing_stdin = true;
 +	break;
 +
 +	/* Common options. */
 +      case 'a': append_to_tagfile = true;	break;
 +      case 'C': cplusplus = true;		break;
 +      case 'f':		/* for compatibility with old makefiles */
 +      case 'o':
 +	if (tagfile)
 +	  {
 +	    error ("-o option may only be given once.");
 +	    suggest_asking_for_help ();
 +	    /* NOTREACHED */
 +	  }
 +	tagfile = optarg;
 +	break;
 +      case 'I':
 +      case 'S':		/* for backward compatibility */
 +	ignoreindent = true;
 +	break;
 +      case 'l':
 +	{
 +	  language *lang = get_language_from_langname (optarg);
 +	  if (lang != NULL)
 +	    {
 +	      argbuffer[current_arg].lang = lang;
 +	      argbuffer[current_arg].arg_type = at_language;
 +	      ++current_arg;
 +	    }
 +	}
 +	break;
 +      case 'c':
 +	/* Backward compatibility: support obsolete --ignore-case-regexp. */
 +	optarg = concat (optarg, "i", ""); /* memory leak here */
 +	/* FALLTHRU */
 +      case 'r':
 +	argbuffer[current_arg].arg_type = at_regexp;
 +	argbuffer[current_arg].what = optarg;
 +	len = strlen (optarg);
 +	if (whatlen_max < len)
 +	  whatlen_max = len;
 +	++current_arg;
 +	break;
 +      case 'R':
 +	argbuffer[current_arg].arg_type = at_regexp;
 +	argbuffer[current_arg].what = NULL;
 +	++current_arg;
 +	break;
 +      case 'V':
 +	print_version ();
 +	break;
 +      case 'h':
 +      case 'H':
 +	help_asked = true;
 +	break;
 +
 +	/* Etags options */
 +      case 'D': constantypedefs = false;			break;
 +      case 'i': included_files[nincluded_files++] = optarg;	break;
 +
 +	/* Ctags options. */
 +      case 'B': searchar = '?';					break;
 +      case 'd': constantypedefs = true;				break;
 +      case 't': typedefs = true;				break;
 +      case 'T': typedefs = typedefs_or_cplusplus = true;	break;
 +      case 'u': update = true;					break;
 +      case 'v': vgrind_style = true;			  /*FALLTHRU*/
 +      case 'x': cxref_style = true;				break;
 +      case 'w': no_warnings = true;				break;
 +      default:
 +	suggest_asking_for_help ();
 +	/* NOTREACHED */
 +      }
 +
 +  /* No more options.  Store the rest of arguments. */
 +  for (; optind < argc; optind++)
 +    {
 +      argbuffer[current_arg].arg_type = at_filename;
 +      argbuffer[current_arg].what = argv[optind];
 +      len = strlen (argv[optind]);
 +      if (whatlen_max < len)
 +	whatlen_max = len;
 +      ++current_arg;
 +      ++file_count;
 +    }
 +
 +  argbuffer[current_arg].arg_type = at_end;
 +
 +  if (help_asked)
 +    print_help (argbuffer);
 +    /* NOTREACHED */
 +
 +  if (nincluded_files == 0 && file_count == 0)
 +    {
 +      error ("no input files specified.");
 +      suggest_asking_for_help ();
 +      /* NOTREACHED */
 +    }
 +
 +  if (tagfile == NULL)
 +    tagfile = savestr (CTAGS ? "tags" : "TAGS");
 +  cwd = etags_getcwd ();	/* the current working directory */
 +  if (cwd[strlen (cwd) - 1] != '/')
 +    {
 +      char *oldcwd = cwd;
 +      cwd = concat (oldcwd, "/", "");
 +      free (oldcwd);
 +    }
 +
 +  /* Compute base directory for relative file names. */
 +  if (streq (tagfile, "-")
 +      || strneq (tagfile, "/dev/", 5))
 +    tagfiledir = cwd;		 /* relative file names are relative to cwd */
 +  else
 +    {
 +      canonicalize_filename (tagfile);
 +      tagfiledir = absolute_dirname (tagfile, cwd);
 +    }
 +
 +  init ();			/* set up boolean "functions" */
 +
 +  linebuffer_init (&lb);
 +  linebuffer_init (&filename_lb);
 +  linebuffer_init (&filebuf);
 +  linebuffer_init (&token_name);
 +
 +  if (!CTAGS)
 +    {
 +      if (streq (tagfile, "-"))
 +	{
 +	  tagf = stdout;
 +	  SET_BINARY (fileno (stdout));
 +	}
 +      else
 +	tagf = fopen (tagfile, append_to_tagfile ? "ab" : "wb");
 +      if (tagf == NULL)
 +	pfatal (tagfile);
 +    }
 +
 +  /*
 +   * Loop through files finding functions.
 +   */
 +  for (i = 0; i < current_arg; i++)
 +    {
 +      static language *lang;	/* non-NULL if language is forced */
 +      char *this_file;
 +
 +      switch (argbuffer[i].arg_type)
 +	{
 +	case at_language:
 +	  lang = argbuffer[i].lang;
 +	  break;
 +	case at_regexp:
 +	  analyze_regex (argbuffer[i].what);
 +	  break;
 +	case at_filename:
 +	      this_file = argbuffer[i].what;
 +	      /* Input file named "-" means read file names from stdin
 +		 (one per line) and use them. */
 +	      if (streq (this_file, "-"))
 +		{
 +		  if (parsing_stdin)
 +		    fatal ("cannot parse standard input AND read file names from it",
 +			   (char *)NULL);
 +		  while (readline_internal (&filename_lb, stdin) > 0)
 +		    process_file_name (filename_lb.buffer, lang);
 +		}
 +	      else
 +		process_file_name (this_file, lang);
 +	  break;
 +        case at_stdin:
 +          this_file = argbuffer[i].what;
 +          process_file (stdin, this_file, lang);
 +          break;
 +	}
 +    }
 +
 +  free_regexps ();
 +  free (lb.buffer);
 +  free (filebuf.buffer);
 +  free (token_name.buffer);
 +
 +  if (!CTAGS || cxref_style)
 +    {
 +      /* Write the remaining tags to tagf (ETAGS) or stdout (CXREF). */
 +      put_entries (nodehead);
 +      free_tree (nodehead);
 +      nodehead = NULL;
 +      if (!CTAGS)
 +	{
 +	  fdesc *fdp;
 +
 +	  /* Output file entries that have no tags. */
 +	  for (fdp = fdhead; fdp != NULL; fdp = fdp->next)
 +	    if (!fdp->written)
 +	      fprintf (tagf, "\f\n%s,0\n", fdp->taggedfname);
 +
 +	  while (nincluded_files-- > 0)
 +	    fprintf (tagf, "\f\n%s,include\n", *included_files++);
 +
 +	  if (fclose (tagf) == EOF)
 +	    pfatal (tagfile);
 +	}
 +
 +      exit (EXIT_SUCCESS);
 +    }
 +
 +  /* From here on, we are in (CTAGS && !cxref_style) */
 +  if (update)
 +    {
 +      char *cmd =
 +	xmalloc (strlen (tagfile) + whatlen_max +
 +		 sizeof "mv..OTAGS;fgrep -v '\t\t' OTAGS >;rm OTAGS");
 +      for (i = 0; i < current_arg; ++i)
 +	{
 +	  switch (argbuffer[i].arg_type)
 +	    {
 +	    case at_filename:
 +	    case at_stdin:
 +	      break;
 +	    default:
 +	      continue;		/* the for loop */
 +	    }
 +	  char *z = stpcpy (cmd, "mv ");
 +	  z = stpcpy (z, tagfile);
 +	  z = stpcpy (z, " OTAGS;fgrep -v '\t");
 +	  z = stpcpy (z, argbuffer[i].what);
 +	  z = stpcpy (z, "\t' OTAGS >");
 +	  z = stpcpy (z, tagfile);
 +	  strcpy (z, ";rm OTAGS");
 +	  if (system (cmd) != EXIT_SUCCESS)
 +	    fatal ("failed to execute shell command", (char *)NULL);
 +	}
 +      free (cmd);
 +      append_to_tagfile = true;
 +    }
 +
 +  tagf = fopen (tagfile, append_to_tagfile ? "ab" : "wb");
 +  if (tagf == NULL)
 +    pfatal (tagfile);
 +  put_entries (nodehead);	/* write all the tags (CTAGS) */
 +  free_tree (nodehead);
 +  nodehead = NULL;
 +  if (fclose (tagf) == EOF)
 +    pfatal (tagfile);
 +
 +  if (CTAGS)
 +    if (append_to_tagfile || update)
 +      {
 +	char *cmd = xmalloc (2 * strlen (tagfile) + sizeof "sort -u -o..");
 +	/* Maybe these should be used:
 +	   setenv ("LC_COLLATE", "C", 1);
 +	   setenv ("LC_ALL", "C", 1); */
 +	char *z = stpcpy (cmd, "sort -u -o ");
 +	z = stpcpy (z, tagfile);
 +	*z++ = ' ';
 +	strcpy (z, tagfile);
 +	exit (system (cmd));
 +      }
 +  return EXIT_SUCCESS;
 +}
 +
 +
 +/*
 + * Return a compressor given the file name.  If EXTPTR is non-zero,
 + * return a pointer into FILE where the compressor-specific
 + * extension begins.  If no compressor is found, NULL is returned
 + * and EXTPTR is not significant.
 + * Idea by Vladimir Alexiev  (1998)
 + */
 +static compressor *
 +get_compressor_from_suffix (char *file, char **extptr)
 +{
 +  compressor *compr;
 +  char *slash, *suffix;
 +
 +  /* File has been processed by canonicalize_filename,
 +     so we don't need to consider backslashes on DOS_NT.  */
 +  slash = strrchr (file, '/');
 +  suffix = strrchr (file, '.');
 +  if (suffix == NULL || suffix < slash)
 +    return NULL;
 +  if (extptr != NULL)
 +    *extptr = suffix;
 +  suffix += 1;
 +  /* Let those poor souls who live with DOS 8+3 file name limits get
 +     some solace by treating foo.cgz as if it were foo.c.gz, etc.
 +     Only the first do loop is run if not MSDOS */
 +  do
 +    {
 +      for (compr = compressors; compr->suffix != NULL; compr++)
 +	if (streq (compr->suffix, suffix))
 +	  return compr;
 +      if (!MSDOS)
 +	break;			/* do it only once: not really a loop */
 +      if (extptr != NULL)
 +	*extptr = ++suffix;
 +    } while (*suffix != '\0');
 +  return NULL;
 +}
 +
 +
 +
 +/*
 + * Return a language given the name.
 + */
 +static language *
 +get_language_from_langname (const char *name)
 +{
 +  language *lang;
 +
 +  if (name == NULL)
 +    error ("empty language name");
 +  else
 +    {
 +      for (lang = lang_names; lang->name != NULL; lang++)
 +	if (streq (name, lang->name))
 +	  return lang;
 +      error ("unknown language \"%s\"", name);
 +    }
 +
 +  return NULL;
 +}
 +
 +
 +/*
 + * Return a language given the interpreter name.
 + */
 +static language *
 +get_language_from_interpreter (char *interpreter)
 +{
 +  language *lang;
 +  const char **iname;
 +
 +  if (interpreter == NULL)
 +    return NULL;
 +  for (lang = lang_names; lang->name != NULL; lang++)
 +    if (lang->interpreters != NULL)
 +      for (iname = lang->interpreters; *iname != NULL; iname++)
 +	if (streq (*iname, interpreter))
 +	    return lang;
 +
 +  return NULL;
 +}
 +
 +
 +
 +/*
 + * Return a language given the file name.
 + */
 +static language *
 +get_language_from_filename (char *file, int case_sensitive)
 +{
 +  language *lang;
 +  const char **name, **ext, *suffix;
 +
 +  /* Try whole file name first. */
 +  for (lang = lang_names; lang->name != NULL; lang++)
 +    if (lang->filenames != NULL)
 +      for (name = lang->filenames; *name != NULL; name++)
 +	if ((case_sensitive)
 +	    ? streq (*name, file)
 +	    : strcaseeq (*name, file))
 +	  return lang;
 +
 +  /* If not found, try suffix after last dot. */
 +  suffix = strrchr (file, '.');
 +  if (suffix == NULL)
 +    return NULL;
 +  suffix += 1;
 +  for (lang = lang_names; lang->name != NULL; lang++)
 +    if (lang->suffixes != NULL)
 +      for (ext = lang->suffixes; *ext != NULL; ext++)
 +	if ((case_sensitive)
 +	    ? streq (*ext, suffix)
 +	    : strcaseeq (*ext, suffix))
 +	  return lang;
 +  return NULL;
 +}
 +
 +
 +/*
 + * This routine is called on each file argument.
 + */
 +static void
 +process_file_name (char *file, language *lang)
 +{
 +  struct stat stat_buf;
 +  FILE *inf;
 +  fdesc *fdp;
 +  compressor *compr;
 +  char *compressed_name, *uncompressed_name;
 +  char *ext, *real_name;
 +  int retval;
 +
 +  canonicalize_filename (file);
 +  if (streq (file, tagfile) && !streq (tagfile, "-"))
 +    {
 +      error ("skipping inclusion of %s in self.", file);
 +      return;
 +    }
 +  if ((compr = get_compressor_from_suffix (file, &ext)) == NULL)
 +    {
 +      compressed_name = NULL;
 +      real_name = uncompressed_name = savestr (file);
 +    }
 +  else
 +    {
 +      real_name = compressed_name = savestr (file);
 +      uncompressed_name = savenstr (file, ext - file);
 +    }
 +
 +  /* If the canonicalized uncompressed name
 +     has already been dealt with, skip it silently. */
 +  for (fdp = fdhead; fdp != NULL; fdp = fdp->next)
 +    {
 +      assert (fdp->infname != NULL);
 +      if (streq (uncompressed_name, fdp->infname))
 +	goto cleanup;
 +    }
 +
 +  if (stat (real_name, &stat_buf) != 0)
 +    {
 +      /* Reset real_name and try with a different name. */
 +      real_name = NULL;
 +      if (compressed_name != NULL) /* try with the given suffix */
 +	{
 +	  if (stat (uncompressed_name, &stat_buf) == 0)
 +	    real_name = uncompressed_name;
 +	}
 +      else			/* try all possible suffixes */
 +	{
 +	  for (compr = compressors; compr->suffix != NULL; compr++)
 +	    {
 +	      compressed_name = concat (file, ".", compr->suffix);
 +	      if (stat (compressed_name, &stat_buf) != 0)
 +		{
 +		  if (MSDOS)
 +		    {
 +		      char *suf = compressed_name + strlen (file);
 +		      size_t suflen = strlen (compr->suffix) + 1;
 +		      for ( ; suf[1]; suf++, suflen--)
 +			{
 +			  memmove (suf, suf + 1, suflen);
 +			  if (stat (compressed_name, &stat_buf) == 0)
 +			    {
 +			      real_name = compressed_name;
 +			      break;
 +			    }
 +			}
 +		      if (real_name != NULL)
 +			break;
 +		    } /* MSDOS */
 +		  free (compressed_name);
 +		  compressed_name = NULL;
 +		}
 +	      else
 +		{
 +		  real_name = compressed_name;
 +		  break;
 +		}
 +	    }
 +	}
 +      if (real_name == NULL)
 +	{
 +	  perror (file);
 +	  goto cleanup;
 +	}
 +    } /* try with a different name */
 +
 +  if (!S_ISREG (stat_buf.st_mode))
 +    {
 +      error ("skipping %s: it is not a regular file.", real_name);
 +      goto cleanup;
 +    }
 +  if (real_name == compressed_name)
 +    {
 +      char *cmd = concat (compr->command, " ", real_name);
 +      inf = popen (cmd, "r" FOPEN_BINARY);
 +      free (cmd);
 +    }
 +  else
 +    inf = fopen (real_name, "r" FOPEN_BINARY);
 +  if (inf == NULL)
 +    {
 +      perror (real_name);
 +      goto cleanup;
 +    }
 +
 +  process_file (inf, uncompressed_name, lang);
 +
 +  if (real_name == compressed_name)
 +    retval = pclose (inf);
 +  else
 +    retval = fclose (inf);
 +  if (retval < 0)
 +    pfatal (file);
 +
 + cleanup:
 +  free (compressed_name);
 +  free (uncompressed_name);
 +  last_node = NULL;
 +  curfdp = NULL;
 +  return;
 +}
 +
 +static void
 +process_file (FILE *fh, char *fn, language *lang)
 +{
 +  static const fdesc emptyfdesc;
 +  fdesc *fdp;
 +
 +  /* Create a new input file description entry. */
 +  fdp = xnew (1, fdesc);
 +  *fdp = emptyfdesc;
 +  fdp->next = fdhead;
 +  fdp->infname = savestr (fn);
 +  fdp->lang = lang;
 +  fdp->infabsname = absolute_filename (fn, cwd);
 +  fdp->infabsdir = absolute_dirname (fn, cwd);
 +  if (filename_is_absolute (fn))
 +    {
 +      /* An absolute file name.  Canonicalize it. */
 +      fdp->taggedfname = absolute_filename (fn, NULL);
 +    }
 +  else
 +    {
 +      /* A file name relative to cwd.  Make it relative
 +	 to the directory of the tags file. */
 +      fdp->taggedfname = relative_filename (fn, tagfiledir);
 +    }
 +  fdp->usecharno = true;	/* use char position when making tags */
 +  fdp->prop = NULL;
 +  fdp->written = false;		/* not written on tags file yet */
 +
 +  fdhead = fdp;
 +  curfdp = fdhead;		/* the current file description */
 +
 +  find_entries (fh);
 +
 +  /* If not Ctags, and if this is not metasource and if it contained no #line
 +     directives, we can write the tags and free all nodes pointing to
 +     curfdp. */
 +  if (!CTAGS
 +      && curfdp->usecharno	/* no #line directives in this file */
 +      && !curfdp->lang->metasource)
 +    {
 +      node *np, *prev;
 +
 +      /* Look for the head of the sublist relative to this file.  See add_node
 +	 for the structure of the node tree. */
 +      prev = NULL;
 +      for (np = nodehead; np != NULL; prev = np, np = np->left)
 +	if (np->fdp == curfdp)
 +	  break;
 +
 +      /* If we generated tags for this file, write and delete them. */
 +      if (np != NULL)
 +	{
 +	  /* This is the head of the last sublist, if any.  The following
 +	     instructions depend on this being true. */
 +	  assert (np->left == NULL);
 +
 +	  assert (fdhead == curfdp);
 +	  assert (last_node->fdp == curfdp);
 +	  put_entries (np);	/* write tags for file curfdp->taggedfname */
 +	  free_tree (np);	/* remove the written nodes */
 +	  if (prev == NULL)
 +	    nodehead = NULL;	/* no nodes left */
 +	  else
 +	    prev->left = NULL;	/* delete the pointer to the sublist */
 +	}
 +    }
 +}
 +
 +/*
 + * This routine sets up the boolean pseudo-functions which work
 + * by setting boolean flags dependent upon the corresponding character.
 + * Every char which is NOT in that string is not a white char.  Therefore,
 + * all of the array "_wht" is set to false, and then the elements
 + * subscripted by the chars in "white" are set to true.  Thus "_wht"
 + * of a char is true if it is the string "white", else false.
 + */
 +static void
 +init (void)
 +{
 +  const char *sp;
 +  int i;
 +
 +  for (i = 0; i < CHARS; i++)
 +    iswhite (i) = notinname (i) = begtoken (i) = intoken (i) = endtoken (i)
 +      = false;
 +  for (sp = white; *sp != '\0'; sp++) iswhite (*sp) = true;
 +  for (sp = nonam; *sp != '\0'; sp++) notinname (*sp) = true;
 +  notinname ('\0') = notinname ('\n');
 +  for (sp = begtk; *sp != '\0'; sp++) begtoken (*sp) = true;
 +  begtoken ('\0') = begtoken ('\n');
 +  for (sp = midtk; *sp != '\0'; sp++) intoken (*sp) = true;
 +  intoken ('\0') = intoken ('\n');
 +  for (sp = endtk; *sp != '\0'; sp++) endtoken (*sp) = true;
 +  endtoken ('\0') = endtoken ('\n');
 +}
 +
 +/*
 + * This routine opens the specified file and calls the function
 + * which finds the function and type definitions.
 + */
 +static void
 +find_entries (FILE *inf)
 +{
 +  char *cp;
 +  language *lang = curfdp->lang;
 +  Lang_function *parser = NULL;
 +
 +  /* If user specified a language, use it. */
 +  if (lang != NULL && lang->function != NULL)
 +    {
 +      parser = lang->function;
 +    }
 +
 +  /* Else try to guess the language given the file name. */
 +  if (parser == NULL)
 +    {
 +      lang = get_language_from_filename (curfdp->infname, true);
 +      if (lang != NULL && lang->function != NULL)
 +	{
 +	  curfdp->lang = lang;
 +	  parser = lang->function;
 +	}
 +    }
 +
 +  /* Else look for sharp-bang as the first two characters. */
 +  if (parser == NULL
 +      && readline_internal (&lb, inf) > 0
 +      && lb.len >= 2
 +      && lb.buffer[0] == '#'
 +      && lb.buffer[1] == '!')
 +    {
 +      char *lp;
 +
 +      /* Set lp to point at the first char after the last slash in the
 +         line or, if no slashes, at the first nonblank.  Then set cp to
 +	 the first successive blank and terminate the string. */
 +      lp = strrchr (lb.buffer+2, '/');
 +      if (lp != NULL)
 +	lp += 1;
 +      else
 +	lp = skip_spaces (lb.buffer + 2);
 +      cp = skip_non_spaces (lp);
 +      *cp = '\0';
 +
 +      if (strlen (lp) > 0)
 +	{
 +	  lang = get_language_from_interpreter (lp);
 +	  if (lang != NULL && lang->function != NULL)
 +	    {
 +	      curfdp->lang = lang;
 +	      parser = lang->function;
 +	    }
 +	}
 +    }
 +
 +  /* We rewind here, even if inf may be a pipe.  We fail if the
 +     length of the first line is longer than the pipe block size,
 +     which is unlikely. */
 +  rewind (inf);
 +
 +  /* Else try to guess the language given the case insensitive file name. */
 +  if (parser == NULL)
 +    {
 +      lang = get_language_from_filename (curfdp->infname, false);
 +      if (lang != NULL && lang->function != NULL)
 +	{
 +	  curfdp->lang = lang;
 +	  parser = lang->function;
 +	}
 +    }
 +
 +  /* Else try Fortran or C. */
 +  if (parser == NULL)
 +    {
 +      node *old_last_node = last_node;
 +
 +      curfdp->lang = get_language_from_langname ("fortran");
 +      find_entries (inf);
 +
 +      if (old_last_node == last_node)
 +	/* No Fortran entries found.  Try C. */
 +	{
 +	  /* We do not tag if rewind fails.
 +	     Only the file name will be recorded in the tags file. */
 +	  rewind (inf);
 +	  curfdp->lang = get_language_from_langname (cplusplus ? "c++" : "c");
 +	  find_entries (inf);
 +	}
 +      return;
 +    }
 +
 +  if (!no_line_directive
 +      && curfdp->lang != NULL && curfdp->lang->metasource)
 +    /* It may be that this is a bingo.y file, and we already parsed a bingo.c
 +       file, or anyway we parsed a file that is automatically generated from
 +       this one.  If this is the case, the bingo.c file contained #line
 +       directives that generated tags pointing to this file.  Let's delete
 +       them all before parsing this file, which is the real source. */
 +    {
 +      fdesc **fdpp = &fdhead;
 +      while (*fdpp != NULL)
 +	if (*fdpp != curfdp
 +	    && streq ((*fdpp)->taggedfname, curfdp->taggedfname))
 +	  /* We found one of those!  We must delete both the file description
 +	     and all tags referring to it. */
 +	  {
 +	    fdesc *badfdp = *fdpp;
 +
 +	    /* Delete the tags referring to badfdp->taggedfname
 +	       that were obtained from badfdp->infname. */
 +	    invalidate_nodes (badfdp, &nodehead);
 +
 +	    *fdpp = badfdp->next; /* remove the bad description from the list */
 +	    free_fdesc (badfdp);
 +	  }
 +	else
 +	  fdpp = &(*fdpp)->next; /* advance the list pointer */
 +    }
 +
 +  assert (parser != NULL);
 +
 +  /* Generic initializations before reading from file. */
 +  linebuffer_setlen (&filebuf, 0); /* reset the file buffer */
 +
 +  /* Generic initializations before parsing file with readline. */
 +  lineno = 0;		       /* reset global line number */
 +  charno = 0;		       /* reset global char number */
 +  linecharno = 0;	       /* reset global char number of line start */
 +
 +  parser (inf);
 +
 +  regex_tag_multiline ();
 +}
 +
 +
 +/*
 + * Check whether an implicitly named tag should be created,
 + * then call `pfnote'.
 + * NAME is a string that is internally copied by this function.
 + *
 + * TAGS format specification
 + * Idea by Sam Kendall  (1997)
 + * The following is explained in some more detail in etc/ETAGS.EBNF.
 + *
 + * make_tag creates tags with "implicit tag names" (unnamed tags)
 + * if the following are all true, assuming NONAM=" \f\t\n\r()=,;":
 + *  1. NAME does not contain any of the characters in NONAM;
 + *  2. LINESTART contains name as either a rightmost, or rightmost but
 + *     one character, substring;
 + *  3. the character, if any, immediately before NAME in LINESTART must
 + *     be a character in NONAM;
 + *  4. the character, if any, immediately after NAME in LINESTART must
 + *     also be a character in NONAM.
 + *
 + * The implementation uses the notinname() macro, which recognizes the
 + * characters stored in the string `nonam'.
 + * etags.el needs to use the same characters that are in NONAM.
 + */
 +static void
 +make_tag (const char *name, 	/* tag name, or NULL if unnamed */
 +	  int namelen,		/* tag length */
 +	  bool is_func,		/* tag is a function */
 +	  char *linestart,	/* start of the line where tag is */
 +	  int linelen,          /* length of the line where tag is */
 +	  int lno,		/* line number */
 +	  long int cno)		/* character number */
 +{
 +  bool named = (name != NULL && namelen > 0);
 +  char *nname = NULL;
 +
 +  if (!CTAGS && named)		/* maybe set named to false */
 +    /* Let's try to make an implicit tag name, that is, create an unnamed tag
 +       such that etags.el can guess a name from it. */
 +    {
 +      int i;
 +      register const char *cp = name;
 +
 +      for (i = 0; i < namelen; i++)
 +	if (notinname (*cp++))
 +	  break;
 +      if (i == namelen)				/* rule #1 */
 +	{
 +	  cp = linestart + linelen - namelen;
 +	  if (notinname (linestart[linelen-1]))
 +	    cp -= 1;				/* rule #4 */
 +	  if (cp >= linestart			/* rule #2 */
 +	      && (cp == linestart
 +		  || notinname (cp[-1]))	/* rule #3 */
 +	      && strneq (name, cp, namelen))	/* rule #2 */
 +	    named = false;	/* use implicit tag name */
 +	}
 +    }
 +
 +  if (named)
 +    nname = savenstr (name, namelen);
 +
 +  pfnote (nname, is_func, linestart, linelen, lno, cno);
 +}
 +
 +/* Record a tag. */
 +static void
 +pfnote (char *name, bool is_func, char *linestart, int linelen, int lno,
 +	long int cno)
 +                		/* tag name, or NULL if unnamed */
 +                  		/* tag is a function */
 +                     		/* start of the line where tag is */
 +                 		/* length of the line where tag is */
 +             			/* line number */
 +              			/* character number */
 +{
 +  register node *np;
 +
 +  assert (name == NULL || name[0] != '\0');
 +  if (CTAGS && name == NULL)
 +    return;
 +
 +  np = xnew (1, node);
 +
 +  /* If ctags mode, change name "main" to M. */
 +  if (CTAGS && !cxref_style && streq (name, "main"))
 +    {
 +      char *fp = strrchr (curfdp->taggedfname, '/');
 +      np->name = concat ("M", fp == NULL ? curfdp->taggedfname : fp + 1, "");
 +      fp = strrchr (np->name, '.');
 +      if (fp != NULL && fp[1] != '\0' && fp[2] == '\0')
 +	fp[0] = '\0';
 +    }
 +  else
 +    np->name = name;
 +  np->valid = true;
 +  np->been_warned = false;
 +  np->fdp = curfdp;
 +  np->is_func = is_func;
 +  np->lno = lno;
 +  if (np->fdp->usecharno)
 +    /* Our char numbers are 0-base, because of C language tradition?
 +       ctags compatibility?  old versions compatibility?   I don't know.
 +       Anyway, since emacs's are 1-base we expect etags.el to take care
 +       of the difference.  If we wanted to have 1-based numbers, we would
 +       uncomment the +1 below. */
 +    np->cno = cno /* + 1 */ ;
 +  else
 +    np->cno = invalidcharno;
 +  np->left = np->right = NULL;
 +  if (CTAGS && !cxref_style)
 +    {
 +      if (strlen (linestart) < 50)
 +	np->regex = concat (linestart, "$", "");
 +      else
 +	np->regex = savenstr (linestart, 50);
 +    }
 +  else
 +    np->regex = savenstr (linestart, linelen);
 +
 +  add_node (np, &nodehead);
 +}
 +
 +/*
 + * free_tree ()
 + *	recurse on left children, iterate on right children.
 + */
 +static void
 +free_tree (register node *np)
 +{
 +  while (np)
 +    {
 +      register node *node_right = np->right;
 +      free_tree (np->left);
 +      free (np->name);
 +      free (np->regex);
 +      free (np);
 +      np = node_right;
 +    }
 +}
 +
 +/*
 + * free_fdesc ()
 + *	delete a file description
 + */
 +static void
 +free_fdesc (register fdesc *fdp)
 +{
 +  free (fdp->infname);
 +  free (fdp->infabsname);
 +  free (fdp->infabsdir);
 +  free (fdp->taggedfname);
 +  free (fdp->prop);
 +  free (fdp);
 +}
 +
 +/*
 + * add_node ()
 + *	Adds a node to the tree of nodes.  In etags mode, sort by file
 + *  	name.  In ctags mode, sort by tag name.  Make no attempt at
 + *    	balancing.
 + *
 + *	add_node is the only function allowed to add nodes, so it can
 + *	maintain state.
 + */
 +static void
 +add_node (node *np, node **cur_node_p)
 +{
 +  register int dif;
 +  register node *cur_node = *cur_node_p;
 +
 +  if (cur_node == NULL)
 +    {
 +      *cur_node_p = np;
 +      last_node = np;
 +      return;
 +    }
 +
 +  if (!CTAGS)
 +    /* Etags Mode */
 +    {
 +      /* For each file name, tags are in a linked sublist on the right
 +	 pointer.  The first tags of different files are a linked list
 +	 on the left pointer.  last_node points to the end of the last
 +	 used sublist. */
 +      if (last_node != NULL && last_node->fdp == np->fdp)
 +	{
 +	  /* Let's use the same sublist as the last added node. */
 +	  assert (last_node->right == NULL);
 +	  last_node->right = np;
 +	  last_node = np;
 +	}
 +      else if (cur_node->fdp == np->fdp)
 +	{
 +	  /* Scanning the list we found the head of a sublist which is
 +	     good for us.  Let's scan this sublist. */
 +	  add_node (np, &cur_node->right);
 +	}
 +      else
 +	/* The head of this sublist is not good for us.  Let's try the
 +	   next one. */
 +	add_node (np, &cur_node->left);
 +    } /* if ETAGS mode */
 +
 +  else
 +    {
 +      /* Ctags Mode */
 +      dif = strcmp (np->name, cur_node->name);
 +
 +      /*
 +       * If this tag name matches an existing one, then
 +       * do not add the node, but maybe print a warning.
 +       */
 +      if (no_duplicates && !dif)
 +	{
 +	  if (np->fdp == cur_node->fdp)
 +	    {
 +	      if (!no_warnings)
 +		{
 +		  fprintf (stderr, "Duplicate entry in file %s, line %d: %s\n",
 +			   np->fdp->infname, lineno, np->name);
 +		  fprintf (stderr, "Second entry ignored\n");
 +		}
 +	    }
 +	  else if (!cur_node->been_warned && !no_warnings)
 +	    {
 +	      fprintf
 +		(stderr,
 +		 "Duplicate entry in files %s and %s: %s (Warning only)\n",
 +		 np->fdp->infname, cur_node->fdp->infname, np->name);
 +	      cur_node->been_warned = true;
 +	    }
 +	  return;
 +	}
 +
 +      /* Actually add the node */
 +      add_node (np, dif < 0 ? &cur_node->left : &cur_node->right);
 +    } /* if CTAGS mode */
 +}
 +
 +/*
 + * invalidate_nodes ()
 + *	Scan the node tree and invalidate all nodes pointing to the
 + *	given file description (CTAGS case) or free them (ETAGS case).
 + */
 +static void
 +invalidate_nodes (fdesc *badfdp, node **npp)
 +{
 +  node *np = *npp;
 +
 +  if (np == NULL)
 +    return;
 +
 +  if (CTAGS)
 +    {
 +      if (np->left != NULL)
 +	invalidate_nodes (badfdp, &np->left);
 +      if (np->fdp == badfdp)
 +	np->valid = false;
 +      if (np->right != NULL)
 +	invalidate_nodes (badfdp, &np->right);
 +    }
 +  else
 +    {
 +      assert (np->fdp != NULL);
 +      if (np->fdp == badfdp)
 +	{
 +	  *npp = np->left;	/* detach the sublist from the list */
 +	  np->left = NULL;	/* isolate it */
 +	  free_tree (np);	/* free it */
 +	  invalidate_nodes (badfdp, npp);
 +	}
 +      else
 +	invalidate_nodes (badfdp, &np->left);
 +    }
 +}
 +
 +
 +static int total_size_of_entries (node *);
 +static int number_len (long) ATTRIBUTE_CONST;
 +
 +/* Length of a non-negative number's decimal representation. */
 +static int
 +number_len (long int num)
 +{
 +  int len = 1;
 +  while ((num /= 10) > 0)
 +    len += 1;
 +  return len;
 +}
 +
 +/*
 + * Return total number of characters that put_entries will output for
 + * the nodes in the linked list at the right of the specified node.
 + * This count is irrelevant with etags.el since emacs 19.34 at least,
 + * but is still supplied for backward compatibility.
 + */
 +static int
 +total_size_of_entries (register node *np)
 +{
 +  register int total = 0;
 +
 +  for (; np != NULL; np = np->right)
 +    if (np->valid)
 +      {
 +	total += strlen (np->regex) + 1;		/* pat\177 */
 +	if (np->name != NULL)
 +	  total += strlen (np->name) + 1;		/* name\001 */
 +	total += number_len ((long) np->lno) + 1;	/* lno, */
 +	if (np->cno != invalidcharno)			/* cno */
 +	  total += number_len (np->cno);
 +	total += 1;					/* newline */
 +      }
 +
 +  return total;
 +}
 +
 +static void
 +put_entries (register node *np)
 +{
 +  register char *sp;
 +  static fdesc *fdp = NULL;
 +
 +  if (np == NULL)
 +    return;
 +
 +  /* Output subentries that precede this one */
 +  if (CTAGS)
 +    put_entries (np->left);
 +
 +  /* Output this entry */
 +  if (np->valid)
 +    {
 +      if (!CTAGS)
 +	{
 +	  /* Etags mode */
 +	  if (fdp != np->fdp)
 +	    {
 +	      fdp = np->fdp;
 +	      fprintf (tagf, "\f\n%s,%d\n",
 +		       fdp->taggedfname, total_size_of_entries (np));
 +	      fdp->written = true;
 +	    }
 +	  fputs (np->regex, tagf);
 +	  fputc ('\177', tagf);
 +	  if (np->name != NULL)
 +	    {
 +	      fputs (np->name, tagf);
 +	      fputc ('\001', tagf);
 +	    }
 +	  fprintf (tagf, "%d,", np->lno);
 +	  if (np->cno != invalidcharno)
 +	    fprintf (tagf, "%ld", np->cno);
 +	  fputs ("\n", tagf);
 +	}
 +      else
 +	{
 +	  /* Ctags mode */
 +	  if (np->name == NULL)
 +	    error ("internal error: NULL name in ctags mode.");
 +
 +	  if (cxref_style)
 +	    {
 +	      if (vgrind_style)
 +		fprintf (stdout, "%s %s %d\n",
 +			 np->name, np->fdp->taggedfname, (np->lno + 63) / 64);
 +	      else
 +		fprintf (stdout, "%-16s %3d %-16s %s\n",
 +			 np->name, np->lno, np->fdp->taggedfname, np->regex);
 +	    }
 +	  else
 +	    {
 +	      fprintf (tagf, "%s\t%s\t", np->name, np->fdp->taggedfname);
 +
 +	      if (np->is_func)
 +		{		/* function or #define macro with args */
 +		  putc (searchar, tagf);
 +		  putc ('^', tagf);
 +
 +		  for (sp = np->regex; *sp; sp++)
 +		    {
 +		      if (*sp == '\\' || *sp == searchar)
 +			putc ('\\', tagf);
 +		      putc (*sp, tagf);
 +		    }
 +		  putc (searchar, tagf);
 +		}
 +	      else
 +		{		/* anything else; text pattern inadequate */
 +		  fprintf (tagf, "%d", np->lno);
 +		}
 +	      putc ('\n', tagf);
 +	    }
 +	}
 +    } /* if this node contains a valid tag */
 +
 +  /* Output subentries that follow this one */
 +  put_entries (np->right);
 +  if (!CTAGS)
 +    put_entries (np->left);
 +}
 +
 +
 +/* C extensions. */
 +#define C_EXT	0x00fff		/* C extensions */
 +#define C_PLAIN 0x00000		/* C */
 +#define C_PLPL	0x00001		/* C++ */
 +#define C_STAR	0x00003		/* C* */
 +#define C_JAVA	0x00005		/* JAVA */
 +#define C_AUTO  0x01000		/* C, but switch to C++ if `class' is met */
 +#define YACC	0x10000		/* yacc file */
 +
 +/*
 + * The C symbol tables.
 + */
 +enum sym_type
 +{
 +  st_none,
 +  st_C_objprot, st_C_objimpl, st_C_objend,
 +  st_C_gnumacro,
 +  st_C_ignore, st_C_attribute,
 +  st_C_javastruct,
 +  st_C_operator,
 +  st_C_class, st_C_template,
 +  st_C_struct, st_C_extern, st_C_enum, st_C_define, st_C_typedef
 +};
 +
 +/* Feed stuff between (but not including) %[ and %] lines to:
 +     gperf -m 5
 +%[
 +%compare-strncmp
 +%enum
 +%struct-type
 +struct C_stab_entry { char *name; int c_ext; enum sym_type type; }
 +%%
 +if,		0,			st_C_ignore
 +for,		0,			st_C_ignore
 +while,		0,			st_C_ignore
 +switch,		0,			st_C_ignore
 +return,		0,			st_C_ignore
 +__attribute__,	0,			st_C_attribute
 +GTY,            0,                      st_C_attribute
 +@interface,	0,			st_C_objprot
 +@protocol,	0,			st_C_objprot
 +@implementation,0,			st_C_objimpl
 +@end,		0,			st_C_objend
 +import,		(C_JAVA & ~C_PLPL),	st_C_ignore
 +package,	(C_JAVA & ~C_PLPL),	st_C_ignore
 +friend,		C_PLPL,			st_C_ignore
 +extends,	(C_JAVA & ~C_PLPL),	st_C_javastruct
 +implements,	(C_JAVA & ~C_PLPL),	st_C_javastruct
 +interface,	(C_JAVA & ~C_PLPL),	st_C_struct
 +class,		0,			st_C_class
 +namespace,	C_PLPL,			st_C_struct
 +domain,		C_STAR,			st_C_struct
 +union,		0,			st_C_struct
 +struct,		0,			st_C_struct
 +extern,		0,			st_C_extern
 +enum,		0,			st_C_enum
 +typedef,	0,			st_C_typedef
 +define,		0,			st_C_define
 +undef,		0,			st_C_define
 +operator,	C_PLPL,			st_C_operator
 +template,	0,			st_C_template
 +# DEFUN used in emacs, the next three used in glibc (SYSCALL only for mach).
 +DEFUN,		0,			st_C_gnumacro
 +SYSCALL,	0,			st_C_gnumacro
 +ENTRY,		0,			st_C_gnumacro
 +PSEUDO,		0,			st_C_gnumacro
 +# These are defined inside C functions, so currently they are not met.
 +# EXFUN used in glibc, DEFVAR_* in emacs.
 +#EXFUN,		0,			st_C_gnumacro
 +#DEFVAR_,	0,			st_C_gnumacro
 +%]
 +and replace lines between %< and %> with its output, then:
 + - remove the #if characterset check
 + - make in_word_set static and not inline. */
 +/*%<*/
 +/* C code produced by gperf version 3.0.1 */
 +/* Command-line: gperf -m 5  */
 +/* Computed positions: -k'2-3' */
 +
 +struct C_stab_entry { const char *name; int c_ext; enum sym_type type; };
 +/* maximum key range = 33, duplicates = 0 */
 +
 +static int
 +hash (const char *str, int len)
 +{
 +  static char const asso_values[] =
 +    {
 +      35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
 +      35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
 +      35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
 +      35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
 +      35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
 +      35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
 +      35, 35, 35, 35, 35, 35, 35, 35, 35,  3,
 +      26, 35, 35, 35, 35, 35, 35, 35, 27, 35,
 +      35, 35, 35, 24,  0, 35, 35, 35, 35,  0,
 +      35, 35, 35, 35, 35,  1, 35, 16, 35,  6,
 +      23,  0,  0, 35, 22,  0, 35, 35,  5,  0,
 +       0, 15,  1, 35,  6, 35,  8, 19, 35, 16,
 +       4,  5, 35, 35, 35, 35, 35, 35, 35, 35,
 +      35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
 +      35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
 +      35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
 +      35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
 +      35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
 +      35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
 +      35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
 +      35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
 +      35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
 +      35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
 +      35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
 +      35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
 +      35, 35, 35, 35, 35, 35
 +    };
 +  int hval = len;
 +
 +  switch (hval)
 +    {
 +      default:
 +        hval += asso_values[(unsigned char) str[2]];
 +      /*FALLTHROUGH*/
 +      case 2:
 +        hval += asso_values[(unsigned char) str[1]];
 +        break;
 +    }
 +  return hval;
 +}
 +
 +static struct C_stab_entry *
 +in_word_set (register const char *str, register unsigned int len)
 +{
 +  enum
 +    {
 +      TOTAL_KEYWORDS = 33,
 +      MIN_WORD_LENGTH = 2,
 +      MAX_WORD_LENGTH = 15,
 +      MIN_HASH_VALUE = 2,
 +      MAX_HASH_VALUE = 34
 +    };
 +
 +  static struct C_stab_entry wordlist[] =
 +    {
 +      {""}, {""},
 +      {"if",		0,			st_C_ignore},
 +      {"GTY",           0,                      st_C_attribute},
 +      {"@end",		0,			st_C_objend},
 +      {"union",		0,			st_C_struct},
 +      {"define",		0,			st_C_define},
 +      {"import",		(C_JAVA & ~C_PLPL),	st_C_ignore},
 +      {"template",	0,			st_C_template},
 +      {"operator",	C_PLPL,			st_C_operator},
 +      {"@interface",	0,			st_C_objprot},
 +      {"implements",	(C_JAVA & ~C_PLPL),	st_C_javastruct},
 +      {"friend",		C_PLPL,			st_C_ignore},
 +      {"typedef",	0,			st_C_typedef},
 +      {"return",		0,			st_C_ignore},
 +      {"@implementation",0,			st_C_objimpl},
 +      {"@protocol",	0,			st_C_objprot},
 +      {"interface",	(C_JAVA & ~C_PLPL),	st_C_struct},
 +      {"extern",		0,			st_C_extern},
 +      {"extends",	(C_JAVA & ~C_PLPL),	st_C_javastruct},
 +      {"struct",		0,			st_C_struct},
 +      {"domain",		C_STAR,			st_C_struct},
 +      {"switch",		0,			st_C_ignore},
 +      {"enum",		0,			st_C_enum},
 +      {"for",		0,			st_C_ignore},
 +      {"namespace",	C_PLPL,			st_C_struct},
 +      {"class",		0,			st_C_class},
 +      {"while",		0,			st_C_ignore},
 +      {"undef",		0,			st_C_define},
 +      {"package",	(C_JAVA & ~C_PLPL),	st_C_ignore},
 +      {"__attribute__",	0,			st_C_attribute},
 +      {"SYSCALL",	0,			st_C_gnumacro},
 +      {"ENTRY",		0,			st_C_gnumacro},
 +      {"PSEUDO",		0,			st_C_gnumacro},
 +      {"DEFUN",		0,			st_C_gnumacro}
 +    };
 +
 +  if (len <= MAX_WORD_LENGTH && len >= MIN_WORD_LENGTH)
 +    {
 +      int key = hash (str, len);
 +
 +      if (key <= MAX_HASH_VALUE && key >= 0)
 +        {
 +          const char *s = wordlist[key].name;
 +
 +          if (*str == *s && !strncmp (str + 1, s + 1, len - 1) && s[len] == '\0')
 +            return &wordlist[key];
 +        }
 +    }
 +  return 0;
 +}
 +/*%>*/
 +
 +static enum sym_type
 +C_symtype (char *str, int len, int c_ext)
 +{
 +  register struct C_stab_entry *se = in_word_set (str, len);
 +
 +  if (se == NULL || (se->c_ext && !(c_ext & se->c_ext)))
 +    return st_none;
 +  return se->type;
 +}
 +
 +
 +/*
 + * Ignoring __attribute__ ((list))
 + */
 +static bool inattribute;	/* looking at an __attribute__ construct */
 +
 +/*
 + * C functions and variables are recognized using a simple
 + * finite automaton.  fvdef is its state variable.
 + */
 +static enum
 +{
 +  fvnone,			/* nothing seen */
 +  fdefunkey,			/* Emacs DEFUN keyword seen */
 +  fdefunname,			/* Emacs DEFUN name seen */
 +  foperator,			/* func: operator keyword seen (cplpl) */
 +  fvnameseen,			/* function or variable name seen */
 +  fstartlist,			/* func: just after open parenthesis */
 +  finlist,			/* func: in parameter list */
 +  flistseen,			/* func: after parameter list */
 +  fignore,			/* func: before open brace */
 +  vignore			/* var-like: ignore until ';' */
 +} fvdef;
 +
 +static bool fvextern;		/* func or var: extern keyword seen; */
 +
 +/*
 + * typedefs are recognized using a simple finite automaton.
 + * typdef is its state variable.
 + */
 +static enum
 +{
 +  tnone,			/* nothing seen */
 +  tkeyseen,			/* typedef keyword seen */
 +  ttypeseen,			/* defined type seen */
 +  tinbody,			/* inside typedef body */
 +  tend,				/* just before typedef tag */
 +  tignore			/* junk after typedef tag */
 +} typdef;
 +
 +/*
 + * struct-like structures (enum, struct and union) are recognized
 + * using another simple finite automaton.  `structdef' is its state
 + * variable.
 + */
 +static enum
 +{
 +  snone,			/* nothing seen yet,
 +				   or in struct body if bracelev > 0 */
 +  skeyseen,			/* struct-like keyword seen */
 +  stagseen,			/* struct-like tag seen */
 +  scolonseen			/* colon seen after struct-like tag */
 +} structdef;
 +
 +/*
 + * When objdef is different from onone, objtag is the name of the class.
 + */
 +static const char *objtag = "";
 +
 +/*
 + * Yet another little state machine to deal with preprocessor lines.
 + */
 +static enum
 +{
 +  dnone,			/* nothing seen */
 +  dsharpseen,			/* '#' seen as first char on line */
 +  ddefineseen,			/* '#' and 'define' seen */
 +  dignorerest			/* ignore rest of line */
 +} definedef;
 +
 +/*
 + * State machine for Objective C protocols and implementations.
 + * Idea by Tom R.Hageman  (1995)
 + */
 +static enum
 +{
 +  onone,			/* nothing seen */
 +  oprotocol,			/* @interface or @protocol seen */
 +  oimplementation,		/* @implementations seen */
 +  otagseen,			/* class name seen */
 +  oparenseen,			/* parenthesis before category seen */
 +  ocatseen,			/* category name seen */
 +  oinbody,			/* in @implementation body */
 +  omethodsign,			/* in @implementation body, after +/- */
 +  omethodtag,			/* after method name */
 +  omethodcolon,			/* after method colon */
 +  omethodparm,			/* after method parameter */
 +  oignore			/* wait for @end */
 +} objdef;
 +
 +
 +/*
 + * Use this structure to keep info about the token read, and how it
 + * should be tagged.  Used by the make_C_tag function to build a tag.
 + */
 +static struct tok
 +{
 +  char *line;			/* string containing the token */
 +  int offset;			/* where the token starts in LINE */
 +  int length;			/* token length */
 +  /*
 +    The previous members can be used to pass strings around for generic
 +    purposes.  The following ones specifically refer to creating tags.  In this
 +    case the token contained here is the pattern that will be used to create a
 +    tag.
 +  */
 +  bool valid;			/* do not create a tag; the token should be
 +				   invalidated whenever a state machine is
 +				   reset prematurely */
 +  bool named;			/* create a named tag */
 +  int lineno;			/* source line number of tag */
 +  long linepos;			/* source char number of tag */
 +} token;			/* latest token read */
 +
 +/*
 + * Variables and functions for dealing with nested structures.
 + * Idea by Mykola Dzyuba  (2001)
 + */
 +static void pushclass_above (int, char *, int);
 +static void popclass_above (int);
 +static void write_classname (linebuffer *, const char *qualifier);
 +
 +static struct {
 +  char **cname;			/* nested class names */
 +  int *bracelev;		/* nested class brace level */
 +  int nl;			/* class nesting level (elements used) */
 +  int size;			/* length of the array */
 +} cstack;			/* stack for nested declaration tags */
 +/* Current struct nesting depth (namespace, class, struct, union, enum). */
 +#define nestlev		(cstack.nl)
 +/* After struct keyword or in struct body, not inside a nested function. */
 +#define instruct	(structdef == snone && nestlev > 0			\
 +			 && bracelev == cstack.bracelev[nestlev-1] + 1)
 +
 +static void
 +pushclass_above (int bracelev, char *str, int len)
 +{
 +  int nl;
 +
 +  popclass_above (bracelev);
 +  nl = cstack.nl;
 +  if (nl >= cstack.size)
 +    {
 +      int size = cstack.size *= 2;
 +      xrnew (cstack.cname, size, char *);
 +      xrnew (cstack.bracelev, size, int);
 +    }
 +  assert (nl == 0 || cstack.bracelev[nl-1] < bracelev);
 +  cstack.cname[nl] = (str == NULL) ? NULL : savenstr (str, len);
 +  cstack.bracelev[nl] = bracelev;
 +  cstack.nl = nl + 1;
 +}
 +
 +static void
 +popclass_above (int bracelev)
 +{
 +  int nl;
 +
 +  for (nl = cstack.nl - 1;
 +       nl >= 0 && cstack.bracelev[nl] >= bracelev;
 +       nl--)
 +    {
 +      free (cstack.cname[nl]);
 +      cstack.nl = nl;
 +    }
 +}
 +
 +static void
 +write_classname (linebuffer *cn, const char *qualifier)
 +{
 +  int i, len;
 +  int qlen = strlen (qualifier);
 +
 +  if (cstack.nl == 0 || cstack.cname[0] == NULL)
 +    {
 +      len = 0;
 +      cn->len = 0;
 +      cn->buffer[0] = '\0';
 +    }
 +  else
 +    {
 +      len = strlen (cstack.cname[0]);
 +      linebuffer_setlen (cn, len);
 +      strcpy (cn->buffer, cstack.cname[0]);
 +    }
 +  for (i = 1; i < cstack.nl; i++)
 +    {
 +      char *s = cstack.cname[i];
 +      if (s == NULL)
 +	continue;
 +      linebuffer_setlen (cn, len + qlen + strlen (s));
 +      len += sprintf (cn->buffer + len, "%s%s", qualifier, s);
 +    }
 +}
 +
 +
 +static bool consider_token (char *, int, int, int *, int, int, bool *);
 +static void make_C_tag (bool);
 +
 +/*
 + * consider_token ()
 + *	checks to see if the current token is at the start of a
 + *	function or variable, or corresponds to a typedef, or
 + * 	is a struct/union/enum tag, or #define, or an enum constant.
 + *
 + *	*IS_FUNC_OR_VAR gets true if the token is a function or #define macro
 + *	with args.  C_EXTP points to which language we are looking at.
 + *
 + * Globals
 + *	fvdef			IN OUT
 + *	structdef		IN OUT
 + *	definedef		IN OUT
 + *	typdef			IN OUT
 + *	objdef			IN OUT
 + */
 +
 +static bool
 +consider_token (char *str, int len, int c, int *c_extp,
 +		int bracelev, int parlev, bool *is_func_or_var)
 +                        	/* IN: token pointer */
 +                      		/* IN: token length */
 +                    		/* IN: first char after the token */
 +                 		/* IN, OUT: C extensions mask */
 +                  		/* IN: brace level */
 +                		/* IN: parenthesis level */
 +                          	/* OUT: function or variable found */
 +{
 +  /* When structdef is stagseen, scolonseen, or snone with bracelev > 0,
 +     structtype is the type of the preceding struct-like keyword, and
 +     structbracelev is the brace level where it has been seen. */
 +  static enum sym_type structtype;
 +  static int structbracelev;
 +  static enum sym_type toktype;
 +
 +
 +  toktype = C_symtype (str, len, *c_extp);
 +
 +  /*
 +   * Skip __attribute__
 +   */
 +  if (toktype == st_C_attribute)
 +    {
 +      inattribute = true;
 +      return false;
 +     }
 +
 +   /*
 +    * Advance the definedef state machine.
 +    */
 +   switch (definedef)
 +     {
 +     case dnone:
 +       /* We're not on a preprocessor line. */
 +       if (toktype == st_C_gnumacro)
 +	 {
 +	   fvdef = fdefunkey;
 +	   return false;
 +	 }
 +       break;
 +     case dsharpseen:
 +       if (toktype == st_C_define)
 +	 {
 +	   definedef = ddefineseen;
 +	 }
 +       else
 +	 {
 +	   definedef = dignorerest;
 +	 }
 +       return false;
 +     case ddefineseen:
 +       /*
 +	* Make a tag for any macro, unless it is a constant
 +	* and constantypedefs is false.
 +	*/
 +       definedef = dignorerest;
 +       *is_func_or_var = (c == '(');
 +       if (!*is_func_or_var && !constantypedefs)
 +	 return false;
 +       else
 +	 return true;
 +     case dignorerest:
 +       return false;
 +     default:
 +       error ("internal error: definedef value.");
 +     }
 +
 +   /*
 +    * Now typedefs
 +    */
 +   switch (typdef)
 +     {
 +     case tnone:
 +       if (toktype == st_C_typedef)
 +	 {
 +	   if (typedefs)
 +	     typdef = tkeyseen;
 +	   fvextern = false;
 +	   fvdef = fvnone;
 +	   return false;
 +	 }
 +       break;
 +     case tkeyseen:
 +       switch (toktype)
 +	 {
 +	 case st_none:
 +	 case st_C_class:
 +	 case st_C_struct:
 +	 case st_C_enum:
 +	   typdef = ttypeseen;
 +	 }
 +       break;
 +     case ttypeseen:
 +       if (structdef == snone && fvdef == fvnone)
 +	 {
 +	   fvdef = fvnameseen;
 +	   return true;
 +	 }
 +       break;
 +     case tend:
 +       switch (toktype)
 +	 {
 +	 case st_C_class:
 +	 case st_C_struct:
 +	 case st_C_enum:
 +	   return false;
 +	 }
 +       return true;
 +     }
 +
 +   switch (toktype)
 +     {
 +     case st_C_javastruct:
 +       if (structdef == stagseen)
 +	 structdef = scolonseen;
 +       return false;
 +     case st_C_template:
 +     case st_C_class:
 +       if ((*c_extp & C_AUTO)	/* automatic detection of C++ language */
 +	   && bracelev == 0
 +	   && definedef == dnone && structdef == snone
 +	   && typdef == tnone && fvdef == fvnone)
 +	 *c_extp = (*c_extp | C_PLPL) & ~C_AUTO;
 +       if (toktype == st_C_template)
 +	 break;
 +       /* FALLTHRU */
 +     case st_C_struct:
 +     case st_C_enum:
 +       if (parlev == 0
 +	   && fvdef != vignore
 +	   && (typdef == tkeyseen
 +	       || (typedefs_or_cplusplus && structdef == snone)))
 +	 {
 +	   structdef = skeyseen;
 +	   structtype = toktype;
 +	   structbracelev = bracelev;
 +	   if (fvdef == fvnameseen)
 +	     fvdef = fvnone;
 +	 }
 +       return false;
 +     }
 +
 +   if (structdef == skeyseen)
 +     {
 +       structdef = stagseen;
 +       return true;
 +     }
 +
 +   if (typdef != tnone)
 +     definedef = dnone;
 +
 +   /* Detect Objective C constructs. */
 +   switch (objdef)
 +     {
 +     case onone:
 +       switch (toktype)
 +	 {
 +	 case st_C_objprot:
 +	   objdef = oprotocol;
 +	   return false;
 +	 case st_C_objimpl:
 +	   objdef = oimplementation;
 +	   return false;
 +	 }
 +       break;
 +     case oimplementation:
 +       /* Save the class tag for functions or variables defined inside. */
 +       objtag = savenstr (str, len);
 +       objdef = oinbody;
 +       return false;
 +     case oprotocol:
 +       /* Save the class tag for categories. */
 +       objtag = savenstr (str, len);
 +       objdef = otagseen;
 +       *is_func_or_var = true;
 +       return true;
 +     case oparenseen:
 +       objdef = ocatseen;
 +       *is_func_or_var = true;
 +       return true;
 +     case oinbody:
 +       break;
 +     case omethodsign:
 +       if (parlev == 0)
 +	 {
 +	   fvdef = fvnone;
 +	   objdef = omethodtag;
 +	   linebuffer_setlen (&token_name, len);
 +	   memcpy (token_name.buffer, str, len);
 +	   token_name.buffer[len] = '\0';
 +	   return true;
 +	 }
 +       return false;
 +     case omethodcolon:
 +       if (parlev == 0)
 +	 objdef = omethodparm;
 +       return false;
 +     case omethodparm:
 +       if (parlev == 0)
 +	 {
 +	   int oldlen = token_name.len;
 +	   fvdef = fvnone;
 +	   objdef = omethodtag;
 +	   linebuffer_setlen (&token_name, oldlen + len);
 +	   memcpy (token_name.buffer + oldlen, str, len);
 +	   token_name.buffer[oldlen + len] = '\0';
 +	   return true;
 +	 }
 +       return false;
 +     case oignore:
 +       if (toktype == st_C_objend)
 +	 {
 +	   /* Memory leakage here: the string pointed by objtag is
 +	      never released, because many tests would be needed to
 +	      avoid breaking on incorrect input code.  The amount of
 +	      memory leaked here is the sum of the lengths of the
 +	      class tags.
 +	   free (objtag); */
 +	   objdef = onone;
 +	 }
 +       return false;
 +     }
 +
 +   /* A function, variable or enum constant? */
 +   switch (toktype)
 +     {
 +     case st_C_extern:
 +       fvextern = true;
 +       switch  (fvdef)
 +	 {
 +	 case finlist:
 +	 case flistseen:
 +	 case fignore:
 +	 case vignore:
 +	   break;
 +	 default:
 +	   fvdef = fvnone;
 +	 }
 +       return false;
 +     case st_C_ignore:
 +       fvextern = false;
 +       fvdef = vignore;
 +       return false;
 +     case st_C_operator:
 +       fvdef = foperator;
 +       *is_func_or_var = true;
 +       return true;
 +     case st_none:
 +       if (constantypedefs
 +	   && structdef == snone
 +	   && structtype == st_C_enum && bracelev > structbracelev
 +	   /* Don't tag tokens in expressions that assign values to enum
 +	      constants.  */
 +	   && fvdef != vignore)
 +	 return true;		/* enum constant */
 +       switch (fvdef)
 +	 {
 +	 case fdefunkey:
 +	   if (bracelev > 0)
 +	     break;
 +	   fvdef = fdefunname;	/* GNU macro */
 +	   *is_func_or_var = true;
 +	   return true;
 +	 case fvnone:
 +	   switch (typdef)
 +	     {
 +	     case ttypeseen:
 +	       return false;
 +	     case tnone:
 +	       if ((strneq (str, "asm", 3) && endtoken (str[3]))
 +		   || (strneq (str, "__asm__", 7) && endtoken (str[7])))
 +		 {
 +		   fvdef = vignore;
 +		   return false;
 +		 }
 +	       break;
 +	     }
 +	  /* FALLTHRU */
 +	  case fvnameseen:
 +	  if (len >= 10 && strneq (str+len-10, "::operator", 10))
 +	    {
 +	      if (*c_extp & C_AUTO) /* automatic detection of C++ */
 +		*c_extp = (*c_extp | C_PLPL) & ~C_AUTO;
 +	      fvdef = foperator;
 +	      *is_func_or_var = true;
 +	      return true;
 +	    }
 +	  if (bracelev > 0 && !instruct)
 +	    break;
 +	  fvdef = fvnameseen;	/* function or variable */
 +	  *is_func_or_var = true;
 +	  return true;
 +	}
 +      break;
 +    }
 +
 +  return false;
 +}
 +
 +
 +/*
 + * C_entries often keeps pointers to tokens or lines which are older than
 + * the line currently read.  By keeping two line buffers, and switching
 + * them at end of line, it is possible to use those pointers.
 + */
 +static struct
 +{
 +  long linepos;
 +  linebuffer lb;
 +} lbs[2];
 +
 +#define current_lb_is_new (newndx == curndx)
 +#define switch_line_buffers() (curndx = 1 - curndx)
 +
 +#define curlb (lbs[curndx].lb)
 +#define newlb (lbs[newndx].lb)
 +#define curlinepos (lbs[curndx].linepos)
 +#define newlinepos (lbs[newndx].linepos)
 +
 +#define plainc ((c_ext & C_EXT) == C_PLAIN)
 +#define cplpl (c_ext & C_PLPL)
 +#define cjava ((c_ext & C_JAVA) == C_JAVA)
 +
 +#define CNL_SAVE_DEFINEDEF()						\
 +do {									\
 +  curlinepos = charno;							\
 +  readline (&curlb, inf);						\
 +  lp = curlb.buffer;							\
 +  quotednl = false;							\
 +  newndx = curndx;							\
 +} while (0)
 +
 +#define CNL()								\
 +do {									\
 +  CNL_SAVE_DEFINEDEF();							\
 +  if (savetoken.valid)							\
 +    {									\
 +      token = savetoken;						\
 +      savetoken.valid = false;						\
 +    }									\
 +  definedef = dnone;							\
 +} while (0)
 +
 +
 +static void
 +make_C_tag (bool isfun)
 +{
 +  /* This function is never called when token.valid is false, but
 +     we must protect against invalid input or internal errors. */
 +  if (token.valid)
 +    make_tag (token_name.buffer, token_name.len, isfun, token.line,
 +	      token.offset+token.length+1, token.lineno, token.linepos);
 +  else if (DEBUG)
 +    {				  /* this branch is optimized away if !DEBUG */
 +      make_tag (concat ("INVALID TOKEN:-->", token_name.buffer, ""),
 +		token_name.len + 17, isfun, token.line,
 +		token.offset+token.length+1, token.lineno, token.linepos);
 +      error ("INVALID TOKEN");
 +    }
 +
 +  token.valid = false;
 +}
 +
 +
 +/*
 + * C_entries ()
 + *	This routine finds functions, variables, typedefs,
 + * 	#define's, enum constants and struct/union/enum definitions in
 + * 	C syntax and adds them to the list.
 + */
 +static void
 +C_entries (int c_ext, FILE *inf)
 +               			/* extension of C */
 +               			/* input file */
 +{
 +  register char c;		/* latest char read; '\0' for end of line */
 +  register char *lp;		/* pointer one beyond the character `c' */
 +  int curndx, newndx;		/* indices for current and new lb */
 +  register int tokoff;		/* offset in line of start of current token */
 +  register int toklen;		/* length of current token */
 +  const char *qualifier;        /* string used to qualify names */
 +  int qlen;			/* length of qualifier */
 +  int bracelev;			/* current brace level */
 +  int bracketlev;		/* current bracket level */
 +  int parlev;			/* current parenthesis level */
 +  int attrparlev;		/* __attribute__ parenthesis level */
 +  int templatelev;		/* current template level */
 +  int typdefbracelev;		/* bracelev where a typedef struct body begun */
 +  bool incomm, inquote, inchar, quotednl, midtoken;
 +  bool yacc_rules;		/* in the rules part of a yacc file */
 +  struct tok savetoken = {0};	/* token saved during preprocessor handling */
 +
 +
 +  linebuffer_init (&lbs[0].lb);
 +  linebuffer_init (&lbs[1].lb);
 +  if (cstack.size == 0)
 +    {
 +      cstack.size = (DEBUG) ? 1 : 4;
 +      cstack.nl = 0;
 +      cstack.cname = xnew (cstack.size, char *);
 +      cstack.bracelev = xnew (cstack.size, int);
 +    }
 +
 +  tokoff = toklen = typdefbracelev = 0; /* keep compiler quiet */
 +  curndx = newndx = 0;
 +  lp = curlb.buffer;
 +  *lp = 0;
 +
 +  fvdef = fvnone; fvextern = false; typdef = tnone;
 +  structdef = snone; definedef = dnone; objdef = onone;
 +  yacc_rules = false;
 +  midtoken = inquote = inchar = incomm = quotednl = false;
 +  token.valid = savetoken.valid = false;
 +  bracelev = bracketlev = parlev = attrparlev = templatelev = 0;
 +  if (cjava)
 +    { qualifier = "."; qlen = 1; }
 +  else
 +    { qualifier = "::"; qlen = 2; }
 +
 +
 +  while (!feof (inf))
 +    {
 +      c = *lp++;
 +      if (c == '\\')
 +	{
 +	  /* If we are at the end of the line, the next character is a
 +	     '\0'; do not skip it, because it is what tells us
 +	     to read the next line.  */
 +	  if (*lp == '\0')
 +	    {
 +	      quotednl = true;
 +	      continue;
 +	    }
 +	  lp++;
 +	  c = ' ';
 +	}
 +      else if (incomm)
 +	{
 +	  switch (c)
 +	    {
 +	    case '*':
 +	      if (*lp == '/')
 +		{
 +		  c = *lp++;
 +		  incomm = false;
 +		}
 +	      break;
 +	    case '\0':
 +	      /* Newlines inside comments do not end macro definitions in
 +		 traditional cpp. */
 +	      CNL_SAVE_DEFINEDEF ();
 +	      break;
 +	    }
 +	  continue;
 +	}
 +      else if (inquote)
 +	{
 +	  switch (c)
 +	    {
 +	    case '"':
 +	      inquote = false;
 +	      break;
 +	    case '\0':
 +	      /* Newlines inside strings do not end macro definitions
 +		 in traditional cpp, even though compilers don't
 +		 usually accept them. */
 +	      CNL_SAVE_DEFINEDEF ();
 +	      break;
 +	    }
 +	  continue;
 +	}
 +      else if (inchar)
 +	{
 +	  switch (c)
 +	    {
 +	    case '\0':
 +	      /* Hmmm, something went wrong. */
 +	      CNL ();
 +	      /* FALLTHRU */
 +	    case '\'':
 +	      inchar = false;
 +	      break;
 +	    }
 +	  continue;
 +	}
 +      else switch (c)
 +	{
 +	case '"':
 +	  inquote = true;
 +	  if (bracketlev > 0)
 +	    continue;
 +	  if (inattribute)
 +	    break;
 +	  switch (fvdef)
 +	    {
 +	    case fdefunkey:
 +	    case fstartlist:
 +	    case finlist:
 +	    case fignore:
 +	    case vignore:
 +	      break;
 +	    default:
 +	      fvextern = false;
 +	      fvdef = fvnone;
 +	    }
 +	  continue;
 +	case '\'':
 +	  inchar = true;
 +	  if (bracketlev > 0)
 +	    continue;
 +	  if (inattribute)
 +	    break;
 +	  if (fvdef != finlist && fvdef != fignore && fvdef != vignore)
 +	    {
 +	      fvextern = false;
 +	      fvdef = fvnone;
 +	    }
 +	  continue;
 +	case '/':
 +	  if (*lp == '*')
 +	    {
 +	      incomm = true;
 +	      lp++;
 +	      c = ' ';
 +	      if (bracketlev > 0)
 +		continue;
 +	    }
 +	  else if (/* cplpl && */ *lp == '/')
 +	    {
 +	      c = '\0';
 +	    }
 +	  break;
 +	case '%':
 +	  if ((c_ext & YACC) && *lp == '%')
 +	    {
 +	      /* Entering or exiting rules section in yacc file. */
 +	      lp++;
 +	      definedef = dnone; fvdef = fvnone; fvextern = false;
 +	      typdef = tnone; structdef = snone;
 +	      midtoken = inquote = inchar = incomm = quotednl = false;
 +	      bracelev = 0;
 +	      yacc_rules = !yacc_rules;
 +	      continue;
 +	    }
 +	  else
 +	    break;
 +	case '#':
 +	  if (definedef == dnone)
 +	    {
 +	      char *cp;
 +	      bool cpptoken = true;
 +
 +	      /* Look back on this line.  If all blanks, or nonblanks
 +		 followed by an end of comment, this is a preprocessor
 +		 token. */
 +	      for (cp = newlb.buffer; cp < lp-1; cp++)
 +		if (!iswhite (*cp))
 +		  {
 +		    if (*cp == '*' && cp[1] == '/')
 +		      {
 +			cp++;
 +			cpptoken = true;
 +		      }
 +		    else
 +		      cpptoken = false;
 +		  }
 +	      if (cpptoken)
 +		{
 +		  definedef = dsharpseen;
 +		  /* This is needed for tagging enum values: when there are
 +		     preprocessor conditionals inside the enum, we need to
 +		     reset the value of fvdef so that the next enum value is
 +		     tagged even though the one before it did not end in a
 +		     comma.  */
 +		  if (fvdef == vignore && instruct && parlev == 0)
 +		    {
 +		      if (strneq (cp, "#if", 3) || strneq (cp, "#el", 3))
 +			fvdef = fvnone;
 +		    }
 +		}
 +	    } /* if (definedef == dnone) */
 +	  continue;
 +	case '[':
 +	  bracketlev++;
 +	  continue;
 +	default:
 +	  if (bracketlev > 0)
 +	    {
 +	      if (c == ']')
 +		--bracketlev;
 +	      else if (c == '\0')
 +		CNL_SAVE_DEFINEDEF ();
 +	      continue;
 +	    }
 +	  break;
 +	} /* switch (c) */
 +
 +
 +      /* Consider token only if some involved conditions are satisfied. */
 +      if (typdef != tignore
 +	  && definedef != dignorerest
 +	  && fvdef != finlist
 +	  && templatelev == 0
 +	  && (definedef != dnone
 +	      || structdef != scolonseen)
 +	  && !inattribute)
 +	{
 +	  if (midtoken)
 +	    {
 +	      if (endtoken (c))
 +		{
 +		  if (c == ':' && *lp == ':' && begtoken (lp[1]))
 +		    /* This handles :: in the middle,
 +		       but not at the beginning of an identifier.
 +		       Also, space-separated :: is not recognized. */
 +		    {
 +		      if (c_ext & C_AUTO) /* automatic detection of C++ */
 +			c_ext = (c_ext | C_PLPL) & ~C_AUTO;
 +		      lp += 2;
 +		      toklen += 2;
 +		      c = lp[-1];
 +		      goto still_in_token;
 +		    }
 +		  else
 +		    {
 +		      bool funorvar = false;
 +
 +		      if (yacc_rules
 +			  || consider_token (newlb.buffer + tokoff, toklen, c,
 +					     &c_ext, bracelev, parlev,
 +					     &funorvar))
 +			{
 +			  if (fvdef == foperator)
 +			    {
 +			      char *oldlp = lp;
 +			      lp = skip_spaces (lp-1);
 +			      if (*lp != '\0')
 +				lp += 1;
 +			      while (*lp != '\0'
 +				     && !iswhite (*lp) && *lp != '(')
 +				lp += 1;
 +			      c = *lp++;
 +			      toklen += lp - oldlp;
 +			    }
 +			  token.named = false;
 +			  if (!plainc
 +			      && nestlev > 0 && definedef == dnone)
 +			    /* in struct body */
 +			    {
 +			      int len;
 +                              write_classname (&token_name, qualifier);
 +			      len = token_name.len;
 +			      linebuffer_setlen (&token_name, len+qlen+toklen);
 +			      sprintf (token_name.buffer + len, "%s%.*s",
 +				       qualifier, toklen, newlb.buffer + tokoff);
 +			      token.named = true;
 +			    }
 +			  else if (objdef == ocatseen)
 +			    /* Objective C category */
 +			    {
 +			      int len = strlen (objtag) + 2 + toklen;
 +			      linebuffer_setlen (&token_name, len);
 +			      sprintf (token_name.buffer, "%s(%.*s)",
 +				       objtag, toklen, newlb.buffer + tokoff);
 +			      token.named = true;
 +			    }
 +			  else if (objdef == omethodtag
 +				   || objdef == omethodparm)
 +			    /* Objective C method */
 +			    {
 +			      token.named = true;
 +			    }
 +			  else if (fvdef == fdefunname)
 +			    /* GNU DEFUN and similar macros */
 +			    {
 +			      bool defun = (newlb.buffer[tokoff] == 'F');
 +			      int off = tokoff;
 +			      int len = toklen;
 +
 +			      /* Rewrite the tag so that emacs lisp DEFUNs
 +				 can be found by their elisp name */
 +			      if (defun)
 +				{
 +				  off += 1;
 +				  len -= 1;
 +				}
 +			      linebuffer_setlen (&token_name, len);
 +			      memcpy (token_name.buffer,
 +				      newlb.buffer + off, len);
 +			      token_name.buffer[len] = '\0';
 +			      if (defun)
 +				while (--len >= 0)
 +				  if (token_name.buffer[len] == '_')
 +				    token_name.buffer[len] = '-';
 +			      token.named = defun;
 +			    }
 +			  else
 +			    {
 +			      linebuffer_setlen (&token_name, toklen);
 +			      memcpy (token_name.buffer,
 +				      newlb.buffer + tokoff, toklen);
 +			      token_name.buffer[toklen] = '\0';
 +			      /* Name macros and members. */
 +			      token.named = (structdef == stagseen
 +					     || typdef == ttypeseen
 +					     || typdef == tend
 +					     || (funorvar
 +						 && definedef == dignorerest)
 +					     || (funorvar
 +						 && definedef == dnone
 +						 && structdef == snone
 +						 && bracelev > 0));
 +			    }
 +			  token.lineno = lineno;
 +			  token.offset = tokoff;
 +			  token.length = toklen;
 +			  token.line = newlb.buffer;
 +			  token.linepos = newlinepos;
 +			  token.valid = true;
 +
 +			  if (definedef == dnone
 +			      && (fvdef == fvnameseen
 +				  || fvdef == foperator
 +				  || structdef == stagseen
 +				  || typdef == tend
 +				  || typdef == ttypeseen
 +				  || objdef != onone))
 +			    {
 +			      if (current_lb_is_new)
 +				switch_line_buffers ();
 +			    }
 +			  else if (definedef != dnone
 +				   || fvdef == fdefunname
 +				   || instruct)
 +			    make_C_tag (funorvar);
 +			}
 +		      else /* not yacc and consider_token failed */
 +			{
 +			  if (inattribute && fvdef == fignore)
 +			    {
 +			      /* We have just met __attribute__ after a
 +				 function parameter list: do not tag the
 +				 function again. */
 +			      fvdef = fvnone;
 +			    }
 +			}
 +		      midtoken = false;
 +		    }
 +		} /* if (endtoken (c)) */
 +	      else if (intoken (c))
 +		still_in_token:
 +		{
 +		  toklen++;
 +		  continue;
 +		}
 +	    } /* if (midtoken) */
 +	  else if (begtoken (c))
 +	    {
 +	      switch (definedef)
 +		{
 +		case dnone:
 +		  switch (fvdef)
 +		    {
 +		    case fstartlist:
 +		      /* This prevents tagging fb in
 +			 void (__attribute__((noreturn)) *fb) (void);
 +			 Fixing this is not easy and not very important. */
 +		      fvdef = finlist;
 +		      continue;
 +		    case flistseen:
 +		      if (plainc || declarations)
 +			{
 +			  make_C_tag (true); /* a function */
 +			  fvdef = fignore;
 +			}
 +		      break;
 +		    }
 +		  if (structdef == stagseen && !cjava)
 +		    {
 +		      popclass_above (bracelev);
 +		      structdef = snone;
 +		    }
 +		  break;
 +		case dsharpseen:
 +		  savetoken = token;
 +		  break;
 +		}
 +	      if (!yacc_rules || lp == newlb.buffer + 1)
 +		{
 +		  tokoff = lp - 1 - newlb.buffer;
 +		  toklen = 1;
 +		  midtoken = true;
 +		}
 +	      continue;
 +	    } /* if (begtoken) */
 +	} /* if must look at token */
 +
 +
 +      /* Detect end of line, colon, comma, semicolon and various braces
 +	 after having handled a token.*/
 +      switch (c)
 +	{
 +	case ':':
 +	  if (inattribute)
 +	    break;
 +	  if (yacc_rules && token.offset == 0 && token.valid)
 +	    {
 +	      make_C_tag (false); /* a yacc function */
 +	      break;
 +	    }
 +	  if (definedef != dnone)
 +	    break;
 +	  switch (objdef)
 +	    {
 +	    case  otagseen:
 +	      objdef = oignore;
 +	      make_C_tag (true); /* an Objective C class */
 +	      break;
 +	    case omethodtag:
 +	    case omethodparm:
 +	      objdef = omethodcolon;
 +	      int toklen = token_name.len;
 +	      linebuffer_setlen (&token_name, toklen + 1);
 +	      strcpy (token_name.buffer + toklen, ":");
 +	      break;
 +	    }
 +	  if (structdef == stagseen)
 +	    {
 +	      structdef = scolonseen;
 +	      break;
 +	    }
 +	  /* Should be useless, but may be work as a safety net. */
 +	  if (cplpl && fvdef == flistseen)
 +	    {
 +	      make_C_tag (true); /* a function */
 +	      fvdef = fignore;
 +	      break;
 +	    }
 +	  break;
 +	case ';':
 +	  if (definedef != dnone || inattribute)
 +	    break;
 +	  switch (typdef)
 +	    {
 +	    case tend:
 +	    case ttypeseen:
 +	      make_C_tag (false); /* a typedef */
 +	      typdef = tnone;
 +	      fvdef = fvnone;
 +	      break;
 +	    case tnone:
 +	    case tinbody:
 +	    case tignore:
 +	      switch (fvdef)
 +		{
 +		case fignore:
 +		  if (typdef == tignore || cplpl)
 +		    fvdef = fvnone;
 +		  break;
 +		case fvnameseen:
 +		  if ((globals && bracelev == 0 && (!fvextern || declarations))
 +		      || (members && instruct))
 +		    make_C_tag (false); /* a variable */
 +		  fvextern = false;
 +		  fvdef = fvnone;
 +		  token.valid = false;
 +		  break;
 +		case flistseen:
 +		  if ((declarations
 +		       && (cplpl || !instruct)
 +		       && (typdef == tnone || (typdef != tignore && instruct)))
 +		      || (members
 +			  && plainc && instruct))
 +		    make_C_tag (true);  /* a function */
 +		  /* FALLTHRU */
 +		default:
 +		  fvextern = false;
 +		  fvdef = fvnone;
 +		  if (declarations
 +		       && cplpl && structdef == stagseen)
 +		    make_C_tag (false);	/* forward declaration */
 +		  else
 +		    token.valid = false;
 +		} /* switch (fvdef) */
 +	      /* FALLTHRU */
 +	    default:
 +	      if (!instruct)
 +		typdef = tnone;
 +	    }
 +	  if (structdef == stagseen)
 +	    structdef = snone;
 +	  break;
 +	case ',':
 +	  if (definedef != dnone || inattribute)
 +	    break;
 +	  switch (objdef)
 +	    {
 +	    case omethodtag:
 +	    case omethodparm:
 +	      make_C_tag (true); /* an Objective C method */
 +	      objdef = oinbody;
 +	      break;
 +	    }
 +	  switch (fvdef)
 +	    {
 +	    case fdefunkey:
 +	    case foperator:
 +	    case fstartlist:
 +	    case finlist:
 +	    case fignore:
 +	      break;
 +	    case vignore:
 +	      if (instruct && parlev == 0)
 +		fvdef = fvnone;
 +	      break;
 +	    case fdefunname:
 +	      fvdef = fignore;
 +	      break;
 +	    case fvnameseen:
 +	      if (parlev == 0
 +		  && ((globals
 +		       && bracelev == 0
 +		       && templatelev == 0
 +		       && (!fvextern || declarations))
 +		      || (members && instruct)))
 +		  make_C_tag (false); /* a variable */
 +	      break;
 +	    case flistseen:
 +	      if ((declarations && typdef == tnone && !instruct)
 +		  || (members && typdef != tignore && instruct))
 +		{
 +		  make_C_tag (true); /* a function */
 +		  fvdef = fvnameseen;
 +		}
 +	      else if (!declarations)
 +		fvdef = fvnone;
 +	      token.valid = false;
 +	      break;
 +	    default:
 +	      fvdef = fvnone;
 +	    }
 +	  if (structdef == stagseen)
 +	    structdef = snone;
 +	  break;
 +	case ']':
 +	  if (definedef != dnone || inattribute)
 +	    break;
 +	  if (structdef == stagseen)
 +	    structdef = snone;
 +	  switch (typdef)
 +	    {
 +	    case ttypeseen:
 +	    case tend:
 +	      typdef = tignore;
 +	      make_C_tag (false);	/* a typedef */
 +	      break;
 +	    case tnone:
 +	    case tinbody:
 +	      switch (fvdef)
 +		{
 +		case foperator:
 +		case finlist:
 +		case fignore:
 +		case vignore:
 +		  break;
 +		case fvnameseen:
 +		  if ((members && bracelev == 1)
 +		      || (globals && bracelev == 0
 +			  && (!fvextern || declarations)))
 +		    make_C_tag (false); /* a variable */
 +		  /* FALLTHRU */
 +		default:
 +		  fvdef = fvnone;
 +		}
 +	      break;
 +	    }
 +	  break;
 +	case '(':
 +	  if (inattribute)
 +	    {
 +	      attrparlev++;
 +	      break;
 +	    }
 +	  if (definedef != dnone)
 +	    break;
 +	  if (objdef == otagseen && parlev == 0)
 +	    objdef = oparenseen;
 +	  switch (fvdef)
 +	    {
 +	    case fvnameseen:
 +	      if (typdef == ttypeseen
 +		  && *lp != '*'
 +		  && !instruct)
 +		{
 +		  /* This handles constructs like:
 +		     typedef void OperatorFun (int fun); */
 +		  make_C_tag (false);
 +		  typdef = tignore;
 +		  fvdef = fignore;
 +		  break;
 +		}
 +	      /* FALLTHRU */
 +	    case foperator:
 +	      fvdef = fstartlist;
 +	      break;
 +	    case flistseen:
 +	      fvdef = finlist;
 +	      break;
 +	    }
 +	  parlev++;
 +	  break;
 +	case ')':
 +	  if (inattribute)
 +	    {
 +	      if (--attrparlev == 0)
 +		inattribute = false;
 +	      break;
 +	    }
 +	  if (definedef != dnone)
 +	    break;
 +	  if (objdef == ocatseen && parlev == 1)
 +	    {
 +	      make_C_tag (true); /* an Objective C category */
 +	      objdef = oignore;
 +	    }
 +	  if (--parlev == 0)
 +	    {
 +	      switch (fvdef)
 +		{
 +		case fstartlist:
 +		case finlist:
 +		  fvdef = flistseen;
 +		  break;
 +		}
 +	      if (!instruct
 +		  && (typdef == tend
 +		      || typdef == ttypeseen))
 +		{
 +		  typdef = tignore;
 +		  make_C_tag (false); /* a typedef */
 +		}
 +	    }
 +	  else if (parlev < 0)	/* can happen due to ill-conceived #if's. */
 +	    parlev = 0;
 +	  break;
 +	case '{':
 +	  if (definedef != dnone)
 +	    break;
 +	  if (typdef == ttypeseen)
 +	    {
 +	      /* Whenever typdef is set to tinbody (currently only
 +		 here), typdefbracelev should be set to bracelev. */
 +	      typdef = tinbody;
 +	      typdefbracelev = bracelev;
 +	    }
 +	  switch (fvdef)
 +	    {
 +	    case flistseen:
 +	      make_C_tag (true);    /* a function */
 +	      /* FALLTHRU */
 +	    case fignore:
 +	      fvdef = fvnone;
 +	      break;
 +	    case fvnone:
 +	      switch (objdef)
 +		{
 +		case otagseen:
 +		  make_C_tag (true); /* an Objective C class */
 +		  objdef = oignore;
 +		  break;
 +		case omethodtag:
 +		case omethodparm:
 +		  make_C_tag (true); /* an Objective C method */
 +		  objdef = oinbody;
 +		  break;
 +		default:
 +		  /* Neutralize `extern "C" {' grot. */
 +		  if (bracelev == 0 && structdef == snone && nestlev == 0
 +		      && typdef == tnone)
 +		    bracelev = -1;
 +		}
 +	      break;
 +	    }
 +	  switch (structdef)
 +	    {
 +	    case skeyseen:	   /* unnamed struct */
 +	      pushclass_above (bracelev, NULL, 0);
 +	      structdef = snone;
 +	      break;
 +	    case stagseen:	   /* named struct or enum */
 +	    case scolonseen:	   /* a class */
 +	      pushclass_above (bracelev,token.line+token.offset, token.length);
 +	      structdef = snone;
 +	      make_C_tag (false);  /* a struct or enum */
 +	      break;
 +	    }
 +	  bracelev += 1;
 +	  break;
 +	case '*':
 +	  if (definedef != dnone)
 +	    break;
 +	  if (fvdef == fstartlist)
 +	    {
 +	      fvdef = fvnone;	/* avoid tagging `foo' in `foo (*bar()) ()' */
 +	      token.valid = false;
 +	    }
 +	  break;
 +	case '}':
 +	  if (definedef != dnone)
 +	    break;
 +	  bracelev -= 1;
 +	  if (!ignoreindent && lp == newlb.buffer + 1)
 +	    {
 +	      if (bracelev != 0)
 +		token.valid = false; /* unexpected value, token unreliable */
 +	      bracelev = 0;	/* reset brace level if first column */
 +	      parlev = 0;	/* also reset paren level, just in case... */
 +	    }
 +	  else if (bracelev < 0)
 +	    {
 +	      token.valid = false; /* something gone amiss, token unreliable */
 +	      bracelev = 0;
 +	    }
 +	  if (bracelev == 0 && fvdef == vignore)
 +	    fvdef = fvnone;		/* end of function */
 +	  popclass_above (bracelev);
 +	  structdef = snone;
 +	  /* Only if typdef == tinbody is typdefbracelev significant. */
 +	  if (typdef == tinbody && bracelev <= typdefbracelev)
 +	    {
 +	      assert (bracelev == typdefbracelev);
 +	      typdef = tend;
 +	    }
 +	  break;
 +	case '=':
 +	  if (definedef != dnone)
 +	    break;
 +	  switch (fvdef)
 +	    {
 +	    case foperator:
 +	    case finlist:
 +	    case fignore:
 +	    case vignore:
 +	      break;
 +	    case fvnameseen:
 +	      if ((members && bracelev == 1)
 +		  || (globals && bracelev == 0 && (!fvextern || declarations)))
 +		make_C_tag (false); /* a variable */
 +	      /* FALLTHRU */
 +	    default:
 +	      fvdef = vignore;
 +	    }
 +	  break;
 +	case '<':
 +	  if (cplpl
 +	      && (structdef == stagseen || fvdef == fvnameseen))
 +	    {
 +	      templatelev++;
 +	      break;
 +	    }
 +	  goto resetfvdef;
 +	case '>':
 +	  if (templatelev > 0)
 +	    {
 +	      templatelev--;
 +	      break;
 +	    }
 +	  goto resetfvdef;
 +	case '+':
 +	case '-':
 +	  if (objdef == oinbody && bracelev == 0)
 +	    {
 +	      objdef = omethodsign;
 +	      break;
 +	    }
 +	  /* FALLTHRU */
 +	resetfvdef:
 +	case '#': case '~': case '&': case '%': case '/':
 +	case '|': case '^': case '!': case '.': case '?':
 +	  if (definedef != dnone)
 +	    break;
 +	  /* These surely cannot follow a function tag in C. */
 +	  switch (fvdef)
 +	    {
 +	    case foperator:
 +	    case finlist:
 +	    case fignore:
 +	    case vignore:
 +	      break;
 +	    default:
 +	      fvdef = fvnone;
 +	    }
 +	  break;
 +	case '\0':
 +	  if (objdef == otagseen)
 +	    {
 +	      make_C_tag (true); /* an Objective C class */
 +	      objdef = oignore;
 +	    }
 +	  /* If a macro spans multiple lines don't reset its state. */
 +	  if (quotednl)
 +	    CNL_SAVE_DEFINEDEF ();
 +	  else
 +	    CNL ();
 +	  break;
 +	} /* switch (c) */
 +
 +    } /* while not eof */
 +
 +  free (lbs[0].lb.buffer);
 +  free (lbs[1].lb.buffer);
 +}
 +
 +/*
 + * Process either a C++ file or a C file depending on the setting
 + * of a global flag.
 + */
 +static void
 +default_C_entries (FILE *inf)
 +{
 +  C_entries (cplusplus ? C_PLPL : C_AUTO, inf);
 +}
 +
 +/* Always do plain C. */
 +static void
 +plain_C_entries (FILE *inf)
 +{
 +  C_entries (0, inf);
 +}
 +
 +/* Always do C++. */
 +static void
 +Cplusplus_entries (FILE *inf)
 +{
 +  C_entries (C_PLPL, inf);
 +}
 +
 +/* Always do Java. */
 +static void
 +Cjava_entries (FILE *inf)
 +{
 +  C_entries (C_JAVA, inf);
 +}
 +
 +/* Always do C*. */
 +static void
 +Cstar_entries (FILE *inf)
 +{
 +  C_entries (C_STAR, inf);
 +}
 +
 +/* Always do Yacc. */
 +static void
 +Yacc_entries (FILE *inf)
 +{
 +  C_entries (YACC, inf);
 +}
 +
 +
 +/* Useful macros. */
 +#define LOOP_ON_INPUT_LINES(file_pointer, line_buffer, char_pointer)	\
 +  for (;			/* loop initialization */		\
 +       !feof (file_pointer)	/* loop test */				\
 +       &&			/* instructions at start of loop */	\
 +	  (readline (&line_buffer, file_pointer),			\
 +           char_pointer = line_buffer.buffer,				\
 +	   true);							\
 +      )
 +
 +#define LOOKING_AT(cp, kw)  /* kw is the keyword, a literal string */	\
 +  ((assert ("" kw), true)   /* syntax error if not a literal string */	\
 +   && strneq ((cp), kw, sizeof (kw)-1)		/* cp points at kw */	\
 +   && notinname ((cp)[sizeof (kw)-1])		/* end of kw */		\
 +   && ((cp) = skip_spaces ((cp)+sizeof (kw)-1))) /* skip spaces */
 +
 +/* Similar to LOOKING_AT but does not use notinname, does not skip */
 +#define LOOKING_AT_NOCASE(cp, kw) /* the keyword is a literal string */	\
 +  ((assert ("" kw), true) /* syntax error if not a literal string */	\
 +   && strncaseeq ((cp), kw, sizeof (kw)-1)	/* cp points at kw */	\
 +   && ((cp) += sizeof (kw)-1))			/* skip spaces */
 +
 +/*
 + * Read a file, but do no processing.  This is used to do regexp
 + * matching on files that have no language defined.
 + */
 +static void
 +just_read_file (FILE *inf)
 +{
 +  while (!feof (inf))
 +    readline (&lb, inf);
 +}
 +
 +
 +/* Fortran parsing */
 +
 +static void F_takeprec (void);
 +static void F_getit (FILE *);
 +
 +static void
 +F_takeprec (void)
 +{
 +  dbp = skip_spaces (dbp);
 +  if (*dbp != '*')
 +    return;
 +  dbp++;
 +  dbp = skip_spaces (dbp);
 +  if (strneq (dbp, "(*)", 3))
 +    {
 +      dbp += 3;
 +      return;
 +    }
 +  if (!ISDIGIT (*dbp))
 +    {
 +      --dbp;			/* force failure */
 +      return;
 +    }
 +  do
 +    dbp++;
 +  while (ISDIGIT (*dbp));
 +}
 +
 +static void
 +F_getit (FILE *inf)
 +{
 +  register char *cp;
 +
 +  dbp = skip_spaces (dbp);
 +  if (*dbp == '\0')
 +    {
 +      readline (&lb, inf);
 +      dbp = lb.buffer;
 +      if (dbp[5] != '&')
 +	return;
 +      dbp += 6;
 +      dbp = skip_spaces (dbp);
 +    }
 +  if (!ISALPHA (*dbp) && *dbp != '_' && *dbp != '$')
 +    return;
 +  for (cp = dbp + 1; *cp != '\0' && intoken (*cp); cp++)
 +    continue;
 +  make_tag (dbp, cp-dbp, true,
 +	    lb.buffer, cp - lb.buffer + 1, lineno, linecharno);
 +}
 +
 +
 +static void
 +Fortran_functions (FILE *inf)
 +{
 +  LOOP_ON_INPUT_LINES (inf, lb, dbp)
 +    {
 +      if (*dbp == '%')
 +	dbp++;			/* Ratfor escape to fortran */
 +      dbp = skip_spaces (dbp);
 +      if (*dbp == '\0')
 +	continue;
 +
 +      if (LOOKING_AT_NOCASE (dbp, "recursive"))
 +	dbp = skip_spaces (dbp);
 +
 +      if (LOOKING_AT_NOCASE (dbp, "pure"))
 +	dbp = skip_spaces (dbp);
 +
 +      if (LOOKING_AT_NOCASE (dbp, "elemental"))
 +	dbp = skip_spaces (dbp);
 +
 +      switch (lowcase (*dbp))
 +	{
 +	case 'i':
 +	  if (nocase_tail ("integer"))
 +	    F_takeprec ();
 +	  break;
 +	case 'r':
 +	  if (nocase_tail ("real"))
 +	    F_takeprec ();
 +	  break;
 +	case 'l':
 +	  if (nocase_tail ("logical"))
 +	    F_takeprec ();
 +	  break;
 +	case 'c':
 +	  if (nocase_tail ("complex") || nocase_tail ("character"))
 +	    F_takeprec ();
 +	  break;
 +	case 'd':
 +	  if (nocase_tail ("double"))
 +	    {
 +	      dbp = skip_spaces (dbp);
 +	      if (*dbp == '\0')
 +		continue;
 +	      if (nocase_tail ("precision"))
 +		break;
 +	      continue;
 +	    }
 +	  break;
 +	}
 +      dbp = skip_spaces (dbp);
 +      if (*dbp == '\0')
 +	continue;
 +      switch (lowcase (*dbp))
 +	{
 +	case 'f':
 +	  if (nocase_tail ("function"))
 +	    F_getit (inf);
 +	  continue;
 +	case 's':
 +	  if (nocase_tail ("subroutine"))
 +	    F_getit (inf);
 +	  continue;
 +	case 'e':
 +	  if (nocase_tail ("entry"))
 +	    F_getit (inf);
 +	  continue;
 +	case 'b':
 +	  if (nocase_tail ("blockdata") || nocase_tail ("block data"))
 +	    {
 +	      dbp = skip_spaces (dbp);
 +	      if (*dbp == '\0')	/* assume un-named */
 +		make_tag ("blockdata", 9, true,
 +			  lb.buffer, dbp - lb.buffer, lineno, linecharno);
 +	      else
 +		F_getit (inf);	/* look for name */
 +	    }
 +	  continue;
 +	}
 +    }
 +}
 +
 +
 +/*
 + * Ada parsing
 + * Original code by
 + * Philippe Waroquiers (1998)
 + */
 +
 +/* Once we are positioned after an "interesting" keyword, let's get
 +   the real tag value necessary. */
 +static void
 +Ada_getit (FILE *inf, const char *name_qualifier)
 +{
 +  register char *cp;
 +  char *name;
 +  char c;
 +
 +  while (!feof (inf))
 +    {
 +      dbp = skip_spaces (dbp);
 +      if (*dbp == '\0'
 +	  || (dbp[0] == '-' && dbp[1] == '-'))
 +	{
 +	  readline (&lb, inf);
 +	  dbp = lb.buffer;
 +	}
 +      switch (lowcase (*dbp))
 +        {
 +        case 'b':
 +          if (nocase_tail ("body"))
 +            {
 +              /* Skipping body of   procedure body   or   package body or ....
 +		 resetting qualifier to body instead of spec. */
 +              name_qualifier = "/b";
 +              continue;
 +            }
 +          break;
 +        case 't':
 +          /* Skipping type of   task type   or   protected type ... */
 +          if (nocase_tail ("type"))
 +            continue;
 +          break;
 +        }
 +      if (*dbp == '"')
 +	{
 +	  dbp += 1;
 +	  for (cp = dbp; *cp != '\0' && *cp != '"'; cp++)
 +	    continue;
 +	}
 +      else
 +	{
 +	  dbp = skip_spaces (dbp);
 +	  for (cp = dbp;
 +	       (*cp != '\0'
 +		&& (ISALPHA (*cp) || ISDIGIT (*cp) || *cp == '_' || *cp == '.'));
 +	       cp++)
 +	    continue;
 +	  if (cp == dbp)
 +	    return;
 +	}
 +      c = *cp;
 +      *cp = '\0';
 +      name = concat (dbp, name_qualifier, "");
 +      *cp = c;
 +      make_tag (name, strlen (name), true,
 +		lb.buffer, cp - lb.buffer + 1, lineno, linecharno);
 +      free (name);
 +      if (c == '"')
 +	dbp = cp + 1;
 +      return;
 +    }
 +}
 +
 +static void
 +Ada_funcs (FILE *inf)
 +{
 +  bool inquote = false;
 +  bool skip_till_semicolumn = false;
 +
 +  LOOP_ON_INPUT_LINES (inf, lb, dbp)
 +    {
 +      while (*dbp != '\0')
 +	{
 +	  /* Skip a string i.e. "abcd". */
 +	  if (inquote || (*dbp == '"'))
 +	    {
 +	      dbp = strchr (dbp + !inquote, '"');
 +	      if (dbp != NULL)
 +		{
 +		  inquote = false;
 +		  dbp += 1;
 +		  continue;	/* advance char */
 +		}
 +	      else
 +		{
 +		  inquote = true;
 +		  break;	/* advance line */
 +		}
 +	    }
 +
 +	  /* Skip comments. */
 +	  if (dbp[0] == '-' && dbp[1] == '-')
 +	    break;		/* advance line */
 +
 +	  /* Skip character enclosed in single quote i.e. 'a'
 +	     and skip single quote starting an attribute i.e. 'Image. */
 +	  if (*dbp == '\'')
 +	    {
 +	      dbp++ ;
 +	      if (*dbp != '\0')
 +		dbp++;
 +	      continue;
 +	    }
 +
 +	  if (skip_till_semicolumn)
 +	    {
 +	      if (*dbp == ';')
 +		skip_till_semicolumn = false;
 +	      dbp++;
 +	      continue;         /* advance char */
 +	    }
 +
 +	  /* Search for beginning of a token.  */
 +	  if (!begtoken (*dbp))
 +	    {
 +	      dbp++;
 +	      continue;		/* advance char */
 +	    }
 +
 +	  /* We are at the beginning of a token. */
 +	  switch (lowcase (*dbp))
 +	    {
 +	    case 'f':
 +	      if (!packages_only && nocase_tail ("function"))
 +		Ada_getit (inf, "/f");
 +	      else
 +		break;		/* from switch */
 +	      continue;		/* advance char */
 +	    case 'p':
 +	      if (!packages_only && nocase_tail ("procedure"))
 +		Ada_getit (inf, "/p");
 +	      else if (nocase_tail ("package"))
 +		Ada_getit (inf, "/s");
 +	      else if (nocase_tail ("protected")) /* protected type */
 +		Ada_getit (inf, "/t");
 +	      else
 +		break;		/* from switch */
 +	      continue;		/* advance char */
 +
 +	    case 'u':
 +	      if (typedefs && !packages_only && nocase_tail ("use"))
 +		{
 +		  /* when tagging types, avoid tagging  use type Pack.Typename;
 +		     for this, we will skip everything till a ; */
 +		  skip_till_semicolumn = true;
 +		  continue;     /* advance char */
 +		}
 +
 +	    case 't':
 +	      if (!packages_only && nocase_tail ("task"))
 +		Ada_getit (inf, "/k");
 +	      else if (typedefs && !packages_only && nocase_tail ("type"))
 +		{
 +		  Ada_getit (inf, "/t");
 +		  while (*dbp != '\0')
 +		    dbp += 1;
 +		}
 +	      else
 +		break;		/* from switch */
 +	      continue;		/* advance char */
 +	    }
 +
 +	  /* Look for the end of the token. */
 +	  while (!endtoken (*dbp))
 +	    dbp++;
 +
 +	} /* advance char */
 +    } /* advance line */
 +}
 +
 +
 +/*
 + * Unix and microcontroller assembly tag handling
 + * Labels:  /^[a-zA-Z_.$][a-zA_Z0-9_.$]*[: ^I^J]/
 + * Idea by Bob Weiner, Motorola Inc. (1994)
 + */
 +static void
 +Asm_labels (FILE *inf)
 +{
 +  register char *cp;
 +
 +  LOOP_ON_INPUT_LINES (inf, lb, cp)
 +    {
 +      /* If first char is alphabetic or one of [_.$], test for colon
 +	 following identifier. */
 +      if (ISALPHA (*cp) || *cp == '_' || *cp == '.' || *cp == '$')
 + 	{
 + 	  /* Read past label. */
 +	  cp++;
 + 	  while (ISALNUM (*cp) || *cp == '_' || *cp == '.' || *cp == '$')
 + 	    cp++;
 + 	  if (*cp == ':' || iswhite (*cp))
 +	    /* Found end of label, so copy it and add it to the table. */
 +	    make_tag (lb.buffer, cp - lb.buffer, true,
 +		      lb.buffer, cp - lb.buffer + 1, lineno, linecharno);
 + 	}
 +    }
 +}
 +
 +
 +/*
 + * Perl support
 + * Perl sub names: /^sub[ \t\n]+[^ \t\n{]+/
 + *                 /^use constant[ \t\n]+[^ \t\n{=,;]+/
 + * Perl variable names: /^(my|local).../
 + * Original code by Bart Robinson  (1995)
 + * Additions by Michael Ernst  (1997)
 + * Ideas by Kai Großjohann  (2001)
 + */
 +static void
 +Perl_functions (FILE *inf)
 +{
 +  char *package = savestr ("main"); /* current package name */
 +  register char *cp;
 +
 +  LOOP_ON_INPUT_LINES (inf, lb, cp)
 +    {
 +      cp = skip_spaces (cp);
 +
 +      if (LOOKING_AT (cp, "package"))
 +	{
 +	  free (package);
 +	  get_tag (cp, &package);
 +	}
 +      else if (LOOKING_AT (cp, "sub"))
 +	{
 +	  char *pos, *sp;
 +
 +	subr:
 +	  sp = cp;
 +	  while (!notinname (*cp))
 +	    cp++;
 +	  if (cp == sp)
 +	    continue;		/* nothing found */
 +	  if ((pos = strchr (sp, ':')) != NULL
 +	      && pos < cp && pos[1] == ':')
 +	    /* The name is already qualified. */
 +	    make_tag (sp, cp - sp, true,
 +		      lb.buffer, cp - lb.buffer + 1, lineno, linecharno);
 +	  else
 +	    /* Qualify it. */
 +	    {
 +	      char savechar, *name;
 +
 +	      savechar = *cp;
 +	      *cp = '\0';
 +	      name = concat (package, "::", sp);
 +	      *cp = savechar;
 +	      make_tag (name, strlen (name), true,
 +			lb.buffer, cp - lb.buffer + 1, lineno, linecharno);
 +	      free (name);
 +	    }
 +	}
 +      else if (LOOKING_AT (cp, "use constant")
 +	       || LOOKING_AT (cp, "use constant::defer"))
 +	{
 +	  /* For hash style multi-constant like
 +	        use constant { FOO => 123,
 +	                       BAR => 456 };
 +	     only the first FOO is picked up.  Parsing across the value
 +	     expressions would be difficult in general, due to possible nested
 +	     hashes, here-documents, etc.  */
 +	  if (*cp == '{')
 +	    cp = skip_spaces (cp+1);
 +	  goto subr;
 + 	}
 +      else if (globals)	/* only if we are tagging global vars */
 + 	{
 +	  /* Skip a qualifier, if any. */
 +	  bool qual = LOOKING_AT (cp, "my") || LOOKING_AT (cp, "local");
 + 	  /* After "my" or "local", but before any following paren or space. */
 +	  char *varstart = cp;
 +
 + 	  if (qual		/* should this be removed?  If yes, how? */
 +	      && (*cp == '$' || *cp == '@' || *cp == '%'))
 + 	    {
 + 	      varstart += 1;
 +	      do
 + 		cp++;
 + 	      while (ISALNUM (*cp) || *cp == '_');
 + 	    }
 + 	  else if (qual)
 + 	    {
 + 	      /* Should be examining a variable list at this point;
 + 		 could insist on seeing an open parenthesis. */
 + 	      while (*cp != '\0' && *cp != ';' && *cp != '=' &&  *cp != ')')
 + 		cp++;
 + 	    }
 +	  else
 +	    continue;
 +
 + 	  make_tag (varstart, cp - varstart, false,
 +		    lb.buffer, cp - lb.buffer + 1, lineno, linecharno);
 +	}
 +    }
 +  free (package);
 +}
 +
 +
 +/*
 + * Python support
 + * Look for /^[\t]*def[ \t\n]+[^ \t\n(:]+/ or /^class[ \t\n]+[^ \t\n(:]+/
 + * Idea by Eric S. Raymond  (1997)
 + * More ideas by seb bacon  (2002)
 + */
 +static void
 +Python_functions (FILE *inf)
 +{
 +  register char *cp;
 +
 +  LOOP_ON_INPUT_LINES (inf, lb, cp)
 +    {
 +      cp = skip_spaces (cp);
 +      if (LOOKING_AT (cp, "def") || LOOKING_AT (cp, "class"))
 +	{
 +	  char *name = cp;
 +	  while (!notinname (*cp) && *cp != ':')
 +	    cp++;
 +	  make_tag (name, cp - name, true,
 +		    lb.buffer, cp - lb.buffer + 1, lineno, linecharno);
 +	}
 +    }
 +}
 +
 +
 +/*
 + * PHP support
 + * Look for:
 + *  - /^[ \t]*function[ \t\n]+[^ \t\n(]+/
 + *  - /^[ \t]*class[ \t\n]+[^ \t\n]+/
 + *  - /^[ \t]*define\(\"[^\"]+/
 + * Only with --members:
 + *  - /^[ \t]*var[ \t\n]+\$[^ \t\n=;]/
 + * Idea by Diez B. Roggisch (2001)
 + */
 +static void
 +PHP_functions (FILE *inf)
 +{
 +  char *cp, *name;
 +  bool search_identifier = false;
 +
 +  LOOP_ON_INPUT_LINES (inf, lb, cp)
 +    {
 +      cp = skip_spaces (cp);
 +      name = cp;
 +      if (search_identifier
 +	  && *cp != '\0')
 +	{
 +	  while (!notinname (*cp))
 +	    cp++;
 +	  make_tag (name, cp - name, true,
 +		    lb.buffer, cp - lb.buffer + 1, lineno, linecharno);
 +	  search_identifier = false;
 +	}
 +      else if (LOOKING_AT (cp, "function"))
 +	{
 +	  if (*cp == '&')
 +	    cp = skip_spaces (cp+1);
 +	  if (*cp != '\0')
 +	    {
 +	      name = cp;
 +	      while (!notinname (*cp))
 +		cp++;
 +	      make_tag (name, cp - name, true,
 +			lb.buffer, cp - lb.buffer + 1, lineno, linecharno);
 +	    }
 +	  else
 +	    search_identifier = true;
 +	}
 +      else if (LOOKING_AT (cp, "class"))
 +	{
 +	  if (*cp != '\0')
 +	    {
 +	      name = cp;
 +	      while (*cp != '\0' && !iswhite (*cp))
 +		cp++;
 +	      make_tag (name, cp - name, false,
 +			lb.buffer, cp - lb.buffer + 1, lineno, linecharno);
 +	    }
 +	  else
 +	    search_identifier = true;
 +	}
 +      else if (strneq (cp, "define", 6)
 +	       && (cp = skip_spaces (cp+6))
 +	       && *cp++ == '('
 +	       && (*cp == '"' || *cp == '\''))
 +	{
 +	  char quote = *cp++;
 +	  name = cp;
 +	  while (*cp != quote && *cp != '\0')
 +	    cp++;
 +	  make_tag (name, cp - name, false,
 +		    lb.buffer, cp - lb.buffer + 1, lineno, linecharno);
 +	}
 +      else if (members
 +	       && LOOKING_AT (cp, "var")
 +	       && *cp == '$')
 +	{
 +	  name = cp;
 +	  while (!notinname (*cp))
 +	    cp++;
 +	  make_tag (name, cp - name, false,
 +		    lb.buffer, cp - lb.buffer + 1, lineno, linecharno);
 +	}
 +    }
 +}
 +
 +
 +/*
 + * Cobol tag functions
 + * We could look for anything that could be a paragraph name.
 + * i.e. anything that starts in column 8 is one word and ends in a full stop.
 + * Idea by Corny de Souza (1993)
 + */
 +static void
 +Cobol_paragraphs (FILE *inf)
 +{
 +  register char *bp, *ep;
 +
 +  LOOP_ON_INPUT_LINES (inf, lb, bp)
 +    {
 +      if (lb.len < 9)
 +	continue;
 +      bp += 8;
 +
 +      /* If eoln, compiler option or comment ignore whole line. */
 +      if (bp[-1] != ' ' || !ISALNUM (bp[0]))
 +        continue;
 +
 +      for (ep = bp; ISALNUM (*ep) || *ep == '-'; ep++)
 +	continue;
 +      if (*ep++ == '.')
 +	make_tag (bp, ep - bp, true,
 +		  lb.buffer, ep - lb.buffer + 1, lineno, linecharno);
 +    }
 +}
 +
 +
 +/*
 + * Makefile support
 + * Ideas by Assar Westerlund  (2001)
 + */
 +static void
 +Makefile_targets (FILE *inf)
 +{
 +  register char *bp;
 +
 +  LOOP_ON_INPUT_LINES (inf, lb, bp)
 +    {
 +      if (*bp == '\t' || *bp == '#')
 +	continue;
 +      while (*bp != '\0' && *bp != '=' && *bp != ':')
 +	bp++;
 +      if (*bp == ':' || (globals && *bp == '='))
 +	{
 +	  /* We should detect if there is more than one tag, but we do not.
 +	     We just skip initial and final spaces. */
 +	  char * namestart = skip_spaces (lb.buffer);
 +	  while (--bp > namestart)
 +	    if (!notinname (*bp))
 +	      break;
 +	  make_tag (namestart, bp - namestart + 1, true,
 +		    lb.buffer, bp - lb.buffer + 2, lineno, linecharno);
 +	}
 +    }
 +}
 +
 +
 +/*
 + * Pascal parsing
 + * Original code by Mosur K. Mohan (1989)
 + *
 + *  Locates tags for procedures & functions.  Doesn't do any type- or
 + *  var-definitions.  It does look for the keyword "extern" or
 + *  "forward" immediately following the procedure statement; if found,
 + *  the tag is skipped.
 + */
 +static void
 +Pascal_functions (FILE *inf)
 +{
 +  linebuffer tline;		/* mostly copied from C_entries */
 +  long save_lcno;
 +  int save_lineno, namelen, taglen;
 +  char c, *name;
 +
 +  bool				/* each of these flags is true if: */
 +    incomment,			/* point is inside a comment */
 +    inquote,			/* point is inside '..' string */
 +    get_tagname,		/* point is after PROCEDURE/FUNCTION
 +				   keyword, so next item = potential tag */
 +    found_tag,			/* point is after a potential tag */
 +    inparms,			/* point is within parameter-list */
 +    verify_tag;			/* point has passed the parm-list, so the
 +				   next token will determine whether this
 +				   is a FORWARD/EXTERN to be ignored, or
 +				   whether it is a real tag */
 +
 +  save_lcno = save_lineno = namelen = taglen = 0; /* keep compiler quiet */
 +  name = NULL;			/* keep compiler quiet */
 +  dbp = lb.buffer;
 +  *dbp = '\0';
 +  linebuffer_init (&tline);
 +
 +  incomment = inquote = false;
 +  found_tag = false;		/* have a proc name; check if extern */
 +  get_tagname = false;		/* found "procedure" keyword	     */
 +  inparms = false;		/* found '(' after "proc"            */
 +  verify_tag = false;		/* check if "extern" is ahead        */
 +
 +
 +  while (!feof (inf))		/* long main loop to get next char */
 +    {
 +      c = *dbp++;
 +      if (c == '\0')		/* if end of line */
 +	{
 +	  readline (&lb, inf);
 +	  dbp = lb.buffer;
 +	  if (*dbp == '\0')
 +	    continue;
 +	  if (!((found_tag && verify_tag)
 +		|| get_tagname))
 +	    c = *dbp++;		/* only if don't need *dbp pointing
 +				   to the beginning of the name of
 +				   the procedure or function */
 +	}
 +      if (incomment)
 +	{
 +	  if (c == '}')		/* within { } comments */
 +	    incomment = false;
 +	  else if (c == '*' && *dbp == ')') /* within (* *) comments */
 +	    {
 +	      dbp++;
 +	      incomment = false;
 +	    }
 +	  continue;
 +	}
 +      else if (inquote)
 +	{
 +	  if (c == '\'')
 +	    inquote = false;
 +	  continue;
 +	}
 +      else
 +	switch (c)
 +	  {
 +	  case '\'':
 +	    inquote = true;	/* found first quote */
 +	    continue;
 +	  case '{':		/* found open { comment */
 +	    incomment = true;
 +	    continue;
 +	  case '(':
 +	    if (*dbp == '*')	/* found open (* comment */
 +	      {
 +		incomment = true;
 +		dbp++;
 +	      }
 +	    else if (found_tag)	/* found '(' after tag, i.e., parm-list */
 +	      inparms = true;
 +	    continue;
 +	  case ')':		/* end of parms list */
 +	    if (inparms)
 +	      inparms = false;
 +	    continue;
 +	  case ';':
 +	    if (found_tag && !inparms) /* end of proc or fn stmt */
 +	      {
 +		verify_tag = true;
 +		break;
 +	      }
 +	    continue;
 +	  }
 +      if (found_tag && verify_tag && (*dbp != ' '))
 +	{
 +	  /* Check if this is an "extern" declaration. */
 +	  if (*dbp == '\0')
 +	    continue;
 +	  if (lowcase (*dbp) == 'e')
 +	    {
 +	      if (nocase_tail ("extern")) /* superfluous, really! */
 +		{
 +		  found_tag = false;
 +		  verify_tag = false;
 +		}
 +	    }
 +	  else if (lowcase (*dbp) == 'f')
 +	    {
 +	      if (nocase_tail ("forward")) /* check for forward reference */
 +		{
 +		  found_tag = false;
 +		  verify_tag = false;
 +		}
 +	    }
 +	  if (found_tag && verify_tag) /* not external proc, so make tag */
 +	    {
 +	      found_tag = false;
 +	      verify_tag = false;
 +	      make_tag (name, namelen, true,
 +			tline.buffer, taglen, save_lineno, save_lcno);
 +	      continue;
 +	    }
 +	}
 +      if (get_tagname)		/* grab name of proc or fn */
 +	{
 +	  char *cp;
 +
 +	  if (*dbp == '\0')
 +	    continue;
 +
 +	  /* Find block name. */
 +	  for (cp = dbp + 1; *cp != '\0' && !endtoken (*cp); cp++)
 +	    continue;
 +
 +	  /* Save all values for later tagging. */
 +	  linebuffer_setlen (&tline, lb.len);
 +	  strcpy (tline.buffer, lb.buffer);
 +	  save_lineno = lineno;
 +	  save_lcno = linecharno;
 +	  name = tline.buffer + (dbp - lb.buffer);
 +	  namelen = cp - dbp;
 +	  taglen = cp - lb.buffer + 1;
 +
 +	  dbp = cp;		/* set dbp to e-o-token */
 +	  get_tagname = false;
 +	  found_tag = true;
 +	  continue;
 +
 +	  /* And proceed to check for "extern". */
 +	}
 +      else if (!incomment && !inquote && !found_tag)
 +	{
 +	  /* Check for proc/fn keywords. */
 +	  switch (lowcase (c))
 +	    {
 +	    case 'p':
 +	      if (nocase_tail ("rocedure")) /* c = 'p', dbp has advanced */
 +		get_tagname = true;
 +	      continue;
 +	    case 'f':
 +	      if (nocase_tail ("unction"))
 +		get_tagname = true;
 +	      continue;
 +	    }
 +	}
 +    } /* while not eof */
 +
 +  free (tline.buffer);
 +}
 +
 +
 +/*
 + * Lisp tag functions
 + *  look for (def or (DEF, quote or QUOTE
 + */
 +
 +static void L_getit (void);
 +
 +static void
 +L_getit (void)
 +{
 +  if (*dbp == '\'')		/* Skip prefix quote */
 +    dbp++;
 +  else if (*dbp == '(')
 +  {
 +    dbp++;
 +    /* Try to skip "(quote " */
 +    if (!LOOKING_AT (dbp, "quote") && !LOOKING_AT (dbp, "QUOTE"))
 +      /* Ok, then skip "(" before name in (defstruct (foo)) */
 +      dbp = skip_spaces (dbp);
 +  }
 +  get_tag (dbp, NULL);
 +}
 +
 +static void
 +Lisp_functions (FILE *inf)
 +{
 +  LOOP_ON_INPUT_LINES (inf, lb, dbp)
 +    {
 +      if (dbp[0] != '(')
 +	continue;
 +
 +      /* "(defvar foo)" is a declaration rather than a definition.  */
 +      if (! declarations)
 +	{
 +	  char *p = dbp + 1;
 +	  if (LOOKING_AT (p, "defvar"))
 +	    {
 +	      p = skip_name (p); /* past var name */
 +	      p = skip_spaces (p);
 +	      if (*p == ')')
 +		continue;
 +	    }
 +	}
 +
 +      if (strneq (dbp + 1, "cl-", 3) || strneq (dbp + 1, "CL-", 3))
 +	dbp += 3;
 +
 +      if (strneq (dbp+1, "def", 3) || strneq (dbp+1, "DEF", 3))
 +	{
 +	  dbp = skip_non_spaces (dbp);
 +	  dbp = skip_spaces (dbp);
 +	  L_getit ();
 +	}
 +      else
 +	{
 +	  /* Check for (foo::defmumble name-defined ... */
 +	  do
 +	    dbp++;
 +	  while (!notinname (*dbp) && *dbp != ':');
 +	  if (*dbp == ':')
 +	    {
 +	      do
 +		dbp++;
 +	      while (*dbp == ':');
 +
 +	      if (strneq (dbp, "def", 3) || strneq (dbp, "DEF", 3))
 +		{
 +		  dbp = skip_non_spaces (dbp);
 +		  dbp = skip_spaces (dbp);
 +		  L_getit ();
 +		}
 +	    }
 +	}
 +    }
 +}
 +
 +
 +/*
 + * Lua script language parsing
 + * Original code by David A. Capello  (2004)
 + *
 + *  "function" and "local function" are tags if they start at column 1.
 + */
 +static void
 +Lua_functions (FILE *inf)
 +{
 +  register char *bp;
 +
 +  LOOP_ON_INPUT_LINES (inf, lb, bp)
 +    {
 +      if (bp[0] != 'f' && bp[0] != 'l')
 +	continue;
 +
 +      (void)LOOKING_AT (bp, "local"); /* skip possible "local" */
 +
 +      if (LOOKING_AT (bp, "function"))
 +	get_tag (bp, NULL);
 +    }
 +}
 +
 +
 +/*
 + * PostScript tags
 + * Just look for lines where the first character is '/'
 + * Also look at "defineps" for PSWrap
 + * Ideas by:
 + *   Richard Mlynarik  (1997)
 + *   Masatake Yamato  (1999)
 + */
 +static void
 +PS_functions (FILE *inf)
 +{
 +  register char *bp, *ep;
 +
 +  LOOP_ON_INPUT_LINES (inf, lb, bp)
 +    {
 +      if (bp[0] == '/')
 +	{
 +	  for (ep = bp+1;
 +	       *ep != '\0' && *ep != ' ' && *ep != '{';
 +	       ep++)
 +	    continue;
 +	  make_tag (bp, ep - bp, true,
 +		    lb.buffer, ep - lb.buffer + 1, lineno, linecharno);
 +	}
 +      else if (LOOKING_AT (bp, "defineps"))
 +	get_tag (bp, NULL);
 +    }
 +}
 +
 +
 +/*
 + * Forth tags
 + * Ignore anything after \ followed by space or in ( )
 + * Look for words defined by :
 + * Look for constant, code, create, defer, value, and variable
 + * OBP extensions:  Look for buffer:, field,
 + * Ideas by Eduardo Horvath  (2004)
 + */
 +static void
 +Forth_words (FILE *inf)
 +{
 +  register char *bp;
 +
 +  LOOP_ON_INPUT_LINES (inf, lb, bp)
 +    while ((bp = skip_spaces (bp))[0] != '\0')
 +      if (bp[0] == '\\' && iswhite (bp[1]))
 +	break;			/* read next line */
 +      else if (bp[0] == '(' && iswhite (bp[1]))
 +	do			/* skip to ) or eol */
 +	  bp++;
 +	while (*bp != ')' && *bp != '\0');
 +      else if ((bp[0] == ':' && iswhite (bp[1]) && bp++)
 +	       || LOOKING_AT_NOCASE (bp, "constant")
 +	       || LOOKING_AT_NOCASE (bp, "code")
 +	       || LOOKING_AT_NOCASE (bp, "create")
 +	       || LOOKING_AT_NOCASE (bp, "defer")
 +	       || LOOKING_AT_NOCASE (bp, "value")
 +	       || LOOKING_AT_NOCASE (bp, "variable")
 +	       || LOOKING_AT_NOCASE (bp, "buffer:")
 +	       || LOOKING_AT_NOCASE (bp, "field"))
 +	get_tag (skip_spaces (bp), NULL); /* Yay!  A definition! */
 +      else
 +	bp = skip_non_spaces (bp);
 +}
 +
 +
 +/*
 + * Scheme tag functions
 + * look for (def... xyzzy
 + *          (def... (xyzzy
 + *          (def ... ((...(xyzzy ....
 + *          (set! xyzzy
 + * Original code by Ken Haase (1985?)
 + */
 +static void
 +Scheme_functions (FILE *inf)
 +{
 +  register char *bp;
 +
 +  LOOP_ON_INPUT_LINES (inf, lb, bp)
 +    {
 +      if (strneq (bp, "(def", 4) || strneq (bp, "(DEF", 4))
 +	{
 +	  bp = skip_non_spaces (bp+4);
 +	  /* Skip over open parens and white space.  Don't continue past
 +	     '\0'. */
 +	  while (*bp && notinname (*bp))
 +	    bp++;
 +	  get_tag (bp, NULL);
 +	}
 +      if (LOOKING_AT (bp, "(SET!") || LOOKING_AT (bp, "(set!"))
 +	get_tag (bp, NULL);
 +    }
 +}
 +
 +
 +/* Find tags in TeX and LaTeX input files.  */
 +
 +/* TEX_toktab is a table of TeX control sequences that define tags.
 + * Each entry records one such control sequence.
 + *
 + * Original code from who knows whom.
 + * Ideas by:
 + *   Stefan Monnier (2002)
 + */
 +
 +static linebuffer *TEX_toktab = NULL; /* Table with tag tokens */
 +
 +/* Default set of control sequences to put into TEX_toktab.
 +   The value of environment var TEXTAGS is prepended to this.  */
 +static const char *TEX_defenv = "\
 +:chapter:section:subsection:subsubsection:eqno:label:ref:cite:bibitem\
 +:part:appendix:entry:index:def\
 +:newcommand:renewcommand:newenvironment:renewenvironment";
 +
 +static void TEX_mode (FILE *);
 +static void TEX_decode_env (const char *, const char *);
 +
 +static char TEX_esc = '\\';
 +static char TEX_opgrp = '{';
 +static char TEX_clgrp = '}';
 +
 +/*
 + * TeX/LaTeX scanning loop.
 + */
 +static void
 +TeX_commands (FILE *inf)
 +{
 +  char *cp;
 +  linebuffer *key;
 +
 +  /* Select either \ or ! as escape character.  */
 +  TEX_mode (inf);
 +
 +  /* Initialize token table once from environment. */
 +  if (TEX_toktab == NULL)
 +    TEX_decode_env ("TEXTAGS", TEX_defenv);
 +
 +  LOOP_ON_INPUT_LINES (inf, lb, cp)
 +    {
 +      /* Look at each TEX keyword in line. */
 +      for (;;)
 +	{
 +	  /* Look for a TEX escape. */
 +	  while (*cp++ != TEX_esc)
 +	    if (cp[-1] == '\0' || cp[-1] == '%')
 +	      goto tex_next_line;
 +
 +	  for (key = TEX_toktab; key->buffer != NULL; key++)
 +	    if (strneq (cp, key->buffer, key->len))
 +	      {
 +		char *p;
 +		int namelen, linelen;
 +		bool opgrp = false;
 +
 +		cp = skip_spaces (cp + key->len);
 +		if (*cp == TEX_opgrp)
 +		  {
 +		    opgrp = true;
 +		    cp++;
 +		  }
 +		for (p = cp;
 +		     (!iswhite (*p) && *p != '#' &&
 +		      *p != TEX_opgrp && *p != TEX_clgrp);
 +		     p++)
 +		  continue;
 +		namelen = p - cp;
 +		linelen = lb.len;
 +		if (!opgrp || *p == TEX_clgrp)
 +		  {
 +		    while (*p != '\0' && *p != TEX_opgrp && *p != TEX_clgrp)
 +		      p++;
 +		    linelen = p - lb.buffer + 1;
 +		  }
 +		make_tag (cp, namelen, true,
 +			  lb.buffer, linelen, lineno, linecharno);
 +		goto tex_next_line; /* We only tag a line once */
 +	      }
 +	}
 +    tex_next_line:
 +      ;
 +    }
 +}
 +
 +#define TEX_LESC '\\'
 +#define TEX_SESC '!'
 +
 +/* Figure out whether TeX's escapechar is '\\' or '!' and set grouping
 +   chars accordingly. */
 +static void
 +TEX_mode (FILE *inf)
 +{
 +  int c;
 +
 +  while ((c = getc (inf)) != EOF)
 +    {
 +      /* Skip to next line if we hit the TeX comment char. */
 +      if (c == '%')
 +	while (c != '\n' && c != EOF)
 +	  c = getc (inf);
 +      else if (c == TEX_LESC || c == TEX_SESC )
 +	break;
 +    }
 +
 +  if (c == TEX_LESC)
 +    {
 +      TEX_esc = TEX_LESC;
 +      TEX_opgrp = '{';
 +      TEX_clgrp = '}';
 +    }
 +  else
 +    {
 +      TEX_esc = TEX_SESC;
 +      TEX_opgrp = '<';
 +      TEX_clgrp = '>';
 +    }
 +  /* If the input file is compressed, inf is a pipe, and rewind may fail.
 +     No attempt is made to correct the situation. */
 +  rewind (inf);
 +}
 +
 +/* Read environment and prepend it to the default string.
 +   Build token table. */
 +static void
 +TEX_decode_env (const char *evarname, const char *defenv)
 +{
 +  register const char *env, *p;
 +  int i, len;
 +
 +  /* Append default string to environment. */
 +  env = getenv (evarname);
 +  if (!env)
 +    env = defenv;
 +  else
 +    env = concat (env, defenv, "");
 +
 +  /* Allocate a token table */
 +  for (len = 1, p = env; p;)
 +    if ((p = strchr (p, ':')) && *++p != '\0')
 +      len++;
 +  TEX_toktab = xnew (len, linebuffer);
 +
 +  /* Unpack environment string into token table. Be careful about */
 +  /* zero-length strings (leading ':', "::" and trailing ':') */
 +  for (i = 0; *env != '\0';)
 +    {
 +      p = strchr (env, ':');
 +      if (!p)			/* End of environment string. */
 +	p = env + strlen (env);
 +      if (p - env > 0)
 +	{			/* Only non-zero strings. */
 +	  TEX_toktab[i].buffer = savenstr (env, p - env);
 +	  TEX_toktab[i].len = p - env;
 +	  i++;
 +	}
 +      if (*p)
 +	env = p + 1;
 +      else
 +	{
 +	  TEX_toktab[i].buffer = NULL; /* Mark end of table. */
 +	  TEX_toktab[i].len = 0;
 +	  break;
 +	}
 +    }
 +}
 +
 +
 +/* Texinfo support.  Dave Love, Mar. 2000.  */
 +static void
 +Texinfo_nodes (FILE *inf)
 +{
 +  char *cp, *start;
 +  LOOP_ON_INPUT_LINES (inf, lb, cp)
 +    if (LOOKING_AT (cp, "@node"))
 +      {
 +	start = cp;
 +	while (*cp != '\0' && *cp != ',')
 +	  cp++;
 +	make_tag (start, cp - start, true,
 +		  lb.buffer, cp - lb.buffer + 1, lineno, linecharno);
 +      }
 +}
 +
 +
 +/*
 + * HTML support.
 + * Contents of , <h1>, <h2>, <h3> are tags.
 + * Contents of <a name=xxx> are tags with name xxx.
 + *
 + * Francesco Potortì, 2002.
 + */
 +static void
 +HTML_labels (FILE *inf)
 +{
 +  bool getnext = false;		/* next text outside of HTML tags is a tag */
 +  bool skiptag = false;		/* skip to the end of the current HTML tag */
 +  bool intag = false;		/* inside an html tag, looking for ID= */
 +  bool inanchor = false;	/* when INTAG, is an anchor, look for NAME= */
 +  char *end;
 +
 +
 +  linebuffer_setlen (&token_name, 0); /* no name in buffer */
 +
 +  LOOP_ON_INPUT_LINES (inf, lb, dbp)
 +    for (;;)			/* loop on the same line */
 +      {
 +	if (skiptag)		/* skip HTML tag */
 +	  {
 +	    while (*dbp != '\0' && *dbp != '>')
 +	      dbp++;
 +	    if (*dbp == '>')
 +	      {
 +		dbp += 1;
 +		skiptag = false;
 +		continue;	/* look on the same line */
 +	      }
 +	    break;		/* go to next line */
 +	  }
 +
 +	else if (intag)	/* look for "name=" or "id=" */
 +	  {
 +	    while (*dbp != '\0' && *dbp != '>'
 +		   && lowcase (*dbp) != 'n' && lowcase (*dbp) != 'i')
 +	      dbp++;
 +	    if (*dbp == '\0')
 +	      break;		/* go to next line */
 +	    if (*dbp == '>')
 +	      {
 +		dbp += 1;
 +		intag = false;
 +		continue;	/* look on the same line */
 +	      }
 +	    if ((inanchor && LOOKING_AT_NOCASE (dbp, "name="))
 +		|| LOOKING_AT_NOCASE (dbp, "id="))
 +	      {
 +		bool quoted = (dbp[0] == '"');
 +
 +		if (quoted)
 +		  for (end = ++dbp; *end != '\0' && *end != '"'; end++)
 +		    continue;
 +		else
 +		  for (end = dbp; *end != '\0' && intoken (*end); end++)
 +		    continue;
 +		linebuffer_setlen (&token_name, end - dbp);
 +		memcpy (token_name.buffer, dbp, end - dbp);
 +		token_name.buffer[end - dbp] = '\0';
 +
 +		dbp = end;
 +		intag = false;	/* we found what we looked for */
 +		skiptag = true; /* skip to the end of the tag */
 +		getnext = true;	/* then grab the text */
 +		continue;	/* look on the same line */
 +	      }
 +	    dbp += 1;
 +	  }
 +
 +	else if (getnext)	/* grab next tokens and tag them */
 +	  {
 +	    dbp = skip_spaces (dbp);
 +	    if (*dbp == '\0')
 +	      break;		/* go to next line */
 +	    if (*dbp == '<')
 +	      {
 +		intag = true;
 +		inanchor = (lowcase (dbp[1]) == 'a' && !intoken (dbp[2]));
 +		continue;	/* look on the same line */
 +	      }
 +
 +	    for (end = dbp + 1; *end != '\0' && *end != '<'; end++)
 +	      continue;
 +	    make_tag (token_name.buffer, token_name.len, true,
 +		      dbp, end - dbp, lineno, linecharno);
 +	    linebuffer_setlen (&token_name, 0);	/* no name in buffer */
 +	    getnext = false;
 +	    break;		/* go to next line */
 +	  }
 +
 +	else			/* look for an interesting HTML tag */
 +	  {
 +	    while (*dbp != '\0' && *dbp != '<')
 +	      dbp++;
 +	    if (*dbp == '\0')
 +	      break;		/* go to next line */
 +	    intag = true;
 +	    if (lowcase (dbp[1]) == 'a' && !intoken (dbp[2]))
 +	      {
 +		inanchor = true;
 +		continue;	/* look on the same line */
 +	      }
 +	    else if (LOOKING_AT_NOCASE (dbp, "<title>")
 +		     || LOOKING_AT_NOCASE (dbp, "<h1>")
 +		     || LOOKING_AT_NOCASE (dbp, "<h2>")
 +		     || LOOKING_AT_NOCASE (dbp, "<h3>"))
 +	      {
 +		intag = false;
 +		getnext = true;
 +		continue;	/* look on the same line */
 +	      }
 +	    dbp += 1;
 +	  }
 +      }
 +}
 +
 +
 +/*
 + * Prolog support
 + *
 + * Assumes that the predicate or rule starts at column 0.
 + * Only the first clause of a predicate or rule is added.
 + * Original code by Sunichirou Sugou (1989)
 + * Rewritten by Anders Lindgren (1996)
 + */
 +static size_t prolog_pr (char *, char *);
 +static void prolog_skip_comment (linebuffer *, FILE *);
 +static size_t prolog_atom (char *, size_t);
 +
 +static void
 +Prolog_functions (FILE *inf)
 +{
 +  char *cp, *last;
 +  size_t len;
 +  size_t allocated;
 +
 +  allocated = 0;
 +  len = 0;
 +  last = NULL;
 +
 +  LOOP_ON_INPUT_LINES (inf, lb, cp)
 +    {
 +      if (cp[0] == '\0')	/* Empty line */
 +	continue;
 +      else if (iswhite (cp[0])) /* Not a predicate */
 +	continue;
 +      else if (cp[0] == '/' && cp[1] == '*')	/* comment. */
 +	prolog_skip_comment (&lb, inf);
 +      else if ((len = prolog_pr (cp, last)) > 0)
 +	{
 +	  /* Predicate or rule.  Store the function name so that we
 +	     only generate a tag for the first clause.  */
 +	  if (last == NULL)
 +	    last = xnew (len + 1, char);
 +	  else if (len + 1 > allocated)
 +	    xrnew (last, len + 1, char);
 +	  allocated = len + 1;
 +	  memcpy (last, cp, len);
 +	  last[len] = '\0';
 +	}
 +    }
 +  free (last);
 +}
 +
 +
 +static void
 +prolog_skip_comment (linebuffer *plb, FILE *inf)
 +{
 +  char *cp;
 +
 +  do
 +    {
 +      for (cp = plb->buffer; *cp != '\0'; cp++)
 +	if (cp[0] == '*' && cp[1] == '/')
 +	  return;
 +      readline (plb, inf);
 +    }
 +  while (!feof (inf));
 +}
 +
 +/*
 + * A predicate or rule definition is added if it matches:
 + *     <beginning of line><Prolog Atom><whitespace>(
 + * or  <beginning of line><Prolog Atom><whitespace>:-
 + *
 + * It is added to the tags database if it doesn't match the
 + * name of the previous clause header.
 + *
 + * Return the size of the name of the predicate or rule, or 0 if no
 + * header was found.
 + */
 +static size_t
 +prolog_pr (char *s, char *last)
 +
 +                		/* Name of last clause. */
 +{
 +  size_t pos;
 +  size_t len;
 +
 +  pos = prolog_atom (s, 0);
 +  if (! pos)
 +    return 0;
 +
 +  len = pos;
 +  pos = skip_spaces (s + pos) - s;
 +
 +  if ((s[pos] == '.'
 +       || (s[pos] == '(' && (pos += 1))
 +       || (s[pos] == ':' && s[pos + 1] == '-' && (pos += 2)))
 +      && (last == NULL		/* save only the first clause */
 +	  || len != strlen (last)
 +	  || !strneq (s, last, len)))
 +	{
 +	  make_tag (s, len, true, s, pos, lineno, linecharno);
 +	  return len;
 +	}
 +  else
 +    return 0;
 +}
 +
 +/*
 + * Consume a Prolog atom.
 + * Return the number of bytes consumed, or 0 if there was an error.
 + *
 + * A prolog atom, in this context, could be one of:
 + * - An alphanumeric sequence, starting with a lower case letter.
 + * - A quoted arbitrary string. Single quotes can escape themselves.
 + *   Backslash quotes everything.
 + */
 +static size_t
 +prolog_atom (char *s, size_t pos)
 +{
 +  size_t origpos;
 +
 +  origpos = pos;
 +
 +  if (ISLOWER (s[pos]) || (s[pos] == '_'))
 +    {
 +      /* The atom is unquoted. */
 +      pos++;
 +      while (ISALNUM (s[pos]) || (s[pos] == '_'))
 +	{
 +	  pos++;
 +	}
 +      return pos - origpos;
 +    }
 +  else if (s[pos] == '\'')
 +    {
 +      pos++;
 +
 +      for (;;)
 +	{
 +	  if (s[pos] == '\'')
 +	    {
 +	      pos++;
 +	      if (s[pos] != '\'')
 +		break;
 +	      pos++;		/* A double quote */
 +	    }
 +	  else if (s[pos] == '\0')
 +	    /* Multiline quoted atoms are ignored. */
 +	    return 0;
 +	  else if (s[pos] == '\\')
 +	    {
 +	      if (s[pos+1] == '\0')
 +		return 0;
 +	      pos += 2;
 +	    }
 +	  else
 +	    pos++;
 +	}
 +      return pos - origpos;
 +    }
 +  else
 +    return 0;
 +}
 +
 +
 +/*
 + * Support for Erlang
 + *
 + * Generates tags for functions, defines, and records.
 + * Assumes that Erlang functions start at column 0.
 + * Original code by Anders Lindgren (1996)
 + */
 +static int erlang_func (char *, char *);
 +static void erlang_attribute (char *);
 +static int erlang_atom (char *);
 +
 +static void
 +Erlang_functions (FILE *inf)
 +{
 +  char *cp, *last;
 +  int len;
 +  int allocated;
 +
 +  allocated = 0;
 +  len = 0;
 +  last = NULL;
 +
 +  LOOP_ON_INPUT_LINES (inf, lb, cp)
 +    {
 +      if (cp[0] == '\0')	/* Empty line */
 +	continue;
 +      else if (iswhite (cp[0])) /* Not function nor attribute */
 +	continue;
 +      else if (cp[0] == '%')	/* comment */
 +	continue;
 +      else if (cp[0] == '"')	/* Sometimes, strings start in column one */
 +	continue;
 +      else if (cp[0] == '-') 	/* attribute, e.g. "-define" */
 +	{
 +	  erlang_attribute (cp);
 +	  if (last != NULL)
 +	    {
 +	      free (last);
 +	      last = NULL;
 +	    }
 +	}
 +      else if ((len = erlang_func (cp, last)) > 0)
 +	{
 +	  /*
 +	   * Function.  Store the function name so that we only
 +	   * generates a tag for the first clause.
 +	   */
 +	  if (last == NULL)
 +	    last = xnew (len + 1, char);
 +	  else if (len + 1 > allocated)
 +	    xrnew (last, len + 1, char);
 +	  allocated = len + 1;
 +	  memcpy (last, cp, len);
 +	  last[len] = '\0';
 +	}
 +    }
 +  free (last);
 +}
 +
 +
 +/*
 + * A function definition is added if it matches:
 + *     <beginning of line><Erlang Atom><whitespace>(
 + *
 + * It is added to the tags database if it doesn't match the
 + * name of the previous clause header.
 + *
 + * Return the size of the name of the function, or 0 if no function
 + * was found.
 + */
 +static int
 +erlang_func (char *s, char *last)
 +
 +                		/* Name of last clause. */
 +{
 +  int pos;
 +  int len;
 +
 +  pos = erlang_atom (s);
 +  if (pos < 1)
 +    return 0;
 +
 +  len = pos;
 +  pos = skip_spaces (s + pos) - s;
 +
 +  /* Save only the first clause. */
 +  if (s[pos++] == '('
 +      && (last == NULL
 +	  || len != (int)strlen (last)
 +	  || !strneq (s, last, len)))
 +	{
 +	  make_tag (s, len, true, s, pos, lineno, linecharno);
 +	  return len;
 +	}
 +
 +  return 0;
 +}
 +
 +
 +/*
 + * Handle attributes.  Currently, tags are generated for defines
 + * and records.
 + *
 + * They are on the form:
 + * -define(foo, bar).
 + * -define(Foo(M, N), M+N).
 + * -record(graph, {vtab = notable, cyclic = true}).
 + */
 +static void
 +erlang_attribute (char *s)
 +{
 +  char *cp = s;
 +
 +  if ((LOOKING_AT (cp, "-define") || LOOKING_AT (cp, "-record"))
 +      && *cp++ == '(')
 +    {
 +      int len = erlang_atom (skip_spaces (cp));
 +      if (len > 0)
 +	make_tag (cp, len, true, s, cp + len - s, lineno, linecharno);
 +    }
 +  return;
 +}
 +
 +
 +/*
 + * Consume an Erlang atom (or variable).
 + * Return the number of bytes consumed, or -1 if there was an error.
 + */
 +static int
 +erlang_atom (char *s)
 +{
 +  int pos = 0;
 +
 +  if (ISALPHA (s[pos]) || s[pos] == '_')
 +    {
 +      /* The atom is unquoted. */
 +      do
 +	pos++;
 +      while (ISALNUM (s[pos]) || s[pos] == '_');
 +    }
 +  else if (s[pos] == '\'')
 +    {
 +      for (pos++; s[pos] != '\''; pos++)
 +	if (s[pos] == '\0'	/* multiline quoted atoms are ignored */
 +	    || (s[pos] == '\\' && s[++pos] == '\0'))
 +	  return 0;
 +      pos++;
 +    }
 +
 +  return pos;
 +}
 +
 +
 +static char *scan_separators (char *);
 +static void add_regex (char *, language *);
 +static char *substitute (char *, char *, struct re_registers *);
 +
 +/*
 + * Take a string like "/blah/" and turn it into "blah", verifying
 + * that the first and last characters are the same, and handling
 + * quoted separator characters.  Actually, stops on the occurrence of
 + * an unquoted separator.  Also process \t, \n, etc. and turn into
 + * appropriate characters. Works in place.  Null terminates name string.
 + * Returns pointer to terminating separator, or NULL for
 + * unterminated regexps.
 + */
 +static char *
 +scan_separators (char *name)
 +{
 +  char sep = name[0];
 +  char *copyto = name;
 +  bool quoted = false;
 +
 +  for (++name; *name != '\0'; ++name)
 +    {
 +      if (quoted)
 +	{
 +	  switch (*name)
 +	    {
 +	    case 'a': *copyto++ = '\007'; break; /* BEL (bell)		 */
 +	    case 'b': *copyto++ = '\b'; break;	 /* BS (back space)	 */
 +	    case 'd': *copyto++ = 0177; break;	 /* DEL (delete)	 */
 +	    case 'e': *copyto++ = 033; break;	 /* ESC (delete)	 */
 +	    case 'f': *copyto++ = '\f'; break;	 /* FF (form feed)	 */
 +	    case 'n': *copyto++ = '\n'; break;	 /* NL (new line)	 */
 +	    case 'r': *copyto++ = '\r'; break;	 /* CR (carriage return) */
 +	    case 't': *copyto++ = '\t'; break;	 /* TAB (horizontal tab) */
 +	    case 'v': *copyto++ = '\v'; break;	 /* VT (vertical tab)    */
 +	    default:
 +	      if (*name == sep)
 +		*copyto++ = sep;
 +	      else
 +		{
 +		  /* Something else is quoted, so preserve the quote. */
 +		  *copyto++ = '\\';
 +		  *copyto++ = *name;
 +		}
 +	      break;
 +	    }
 +	  quoted = false;
 +	}
 +      else if (*name == '\\')
 +	quoted = true;
 +      else if (*name == sep)
 +	break;
 +      else
 +	*copyto++ = *name;
 +    }
 +  if (*name != sep)
 +    name = NULL;		/* signal unterminated regexp */
 +
 +  /* Terminate copied string. */
 +  *copyto = '\0';
 +  return name;
 +}
 +
 +/* Look at the argument of --regex or --no-regex and do the right
 +   thing.  Same for each line of a regexp file. */
 +static void
 +analyze_regex (char *regex_arg)
 +{
 +  if (regex_arg == NULL)
 +    {
 +      free_regexps ();		/* --no-regex: remove existing regexps */
 +      return;
 +    }
 +
 +  /* A real --regexp option or a line in a regexp file. */
 +  switch (regex_arg[0])
 +    {
 +      /* Comments in regexp file or null arg to --regex. */
 +    case '\0':
 +    case ' ':
 +    case '\t':
 +      break;
 +
 +      /* Read a regex file.  This is recursive and may result in a
 +	 loop, which will stop when the file descriptors are exhausted. */
 +    case '@':
 +      {
 +	FILE *regexfp;
 +	linebuffer regexbuf;
 +	char *regexfile = regex_arg + 1;
 +
 +	/* regexfile is a file containing regexps, one per line. */
 +	regexfp = fopen (regexfile, "r" FOPEN_BINARY);
 +	if (regexfp == NULL)
 +	  pfatal (regexfile);
 +	linebuffer_init (®exbuf);
 +	while (readline_internal (®exbuf, regexfp) > 0)
 +	  analyze_regex (regexbuf.buffer);
 +	free (regexbuf.buffer);
 +	fclose (regexfp);
 +      }
 +      break;
 +
 +      /* Regexp to be used for a specific language only. */
 +    case '{':
 +      {
 +	language *lang;
 +	char *lang_name = regex_arg + 1;
 +	char *cp;
 +
 +	for (cp = lang_name; *cp != '}'; cp++)
 +	  if (*cp == '\0')
 +	    {
 +	      error ("unterminated language name in regex: %s", regex_arg);
 +	      return;
 +	    }
 +	*cp++ = '\0';
 +	lang = get_language_from_langname (lang_name);
 +	if (lang == NULL)
 +	  return;
 +	add_regex (cp, lang);
 +      }
 +      break;
 +
 +      /* Regexp to be used for any language. */
 +    default:
 +      add_regex (regex_arg, NULL);
 +      break;
 +    }
 +}
 +
 +/* Separate the regexp pattern, compile it,
 +   and care for optional name and modifiers. */
 +static void
 +add_regex (char *regexp_pattern, language *lang)
 +{
 +  static struct re_pattern_buffer zeropattern;
 +  char sep, *pat, *name, *modifiers;
 +  char empty = '\0';
 +  const char *err;
 +  struct re_pattern_buffer *patbuf;
 +  regexp *rp;
 +  bool
 +    force_explicit_name = true, /* do not use implicit tag names */
 +    ignore_case = false,	/* case is significant */
 +    multi_line = false,		/* matches are done one line at a time */
 +    single_line = false;	/* dot does not match newline */
 +
 +
 +  if (strlen (regexp_pattern) < 3)
 +    {
 +      error ("null regexp");
 +      return;
 +    }
 +  sep = regexp_pattern[0];
 +  name = scan_separators (regexp_pattern);
 +  if (name == NULL)
 +    {
 +      error ("%s: unterminated regexp", regexp_pattern);
 +      return;
 +    }
 +  if (name[1] == sep)
 +    {
 +      error ("null name for regexp \"%s\"", regexp_pattern);
 +      return;
 +    }
 +  modifiers = scan_separators (name);
 +  if (modifiers == NULL)	/* no terminating separator --> no name */
 +    {
 +      modifiers = name;
 +      name = ∅
 +    }
 +  else
 +    modifiers += 1;		/* skip separator */
 +
 +  /* Parse regex modifiers. */
 +  for (; modifiers[0] != '\0'; modifiers++)
 +    switch (modifiers[0])
 +      {
 +      case 'N':
 +	if (modifiers == name)
 +	  error ("forcing explicit tag name but no name, ignoring");
 +	force_explicit_name = true;
 +	break;
 +      case 'i':
 +	ignore_case = true;
 +	break;
 +      case 's':
 +	single_line = true;
 +	/* FALLTHRU */
 +      case 'm':
 +	multi_line = true;
 +	need_filebuf = true;
 +	break;
 +      default:
 +	error ("invalid regexp modifier `%c', ignoring", modifiers[0]);
 +	break;
 +      }
 +
 +  patbuf = xnew (1, struct re_pattern_buffer);
 +  *patbuf = zeropattern;
 +  if (ignore_case)
 +    {
 +      static char lc_trans[CHARS];
 +      int i;
 +      for (i = 0; i < CHARS; i++)
 +	lc_trans[i] = lowcase (i);
 +      patbuf->translate = lc_trans;	/* translation table to fold case  */
 +    }
 +
 +  if (multi_line)
 +    pat = concat ("^", regexp_pattern, ""); /* anchor to beginning of line */
 +  else
 +    pat = regexp_pattern;
 +
 +  if (single_line)
 +    re_set_syntax (RE_SYNTAX_EMACS | RE_DOT_NEWLINE);
 +  else
 +    re_set_syntax (RE_SYNTAX_EMACS);
 +
 +  err = re_compile_pattern (pat, strlen (pat), patbuf);
 +  if (multi_line)
 +    free (pat);
 +  if (err != NULL)
 +    {
 +      error ("%s while compiling pattern", err);
 +      return;
 +    }
 +
 +  rp = p_head;
 +  p_head = xnew (1, regexp);
 +  p_head->pattern = savestr (regexp_pattern);
 +  p_head->p_next = rp;
 +  p_head->lang = lang;
 +  p_head->pat = patbuf;
 +  p_head->name = savestr (name);
 +  p_head->error_signaled = false;
 +  p_head->force_explicit_name = force_explicit_name;
 +  p_head->ignore_case = ignore_case;
 +  p_head->multi_line = multi_line;
 +}
 +
 +/*
 + * Do the substitutions indicated by the regular expression and
 + * arguments.
 + */
 +static char *
 +substitute (char *in, char *out, struct re_registers *regs)
 +{
 +  char *result, *t;
 +  int size, dig, diglen;
 +
 +  result = NULL;
 +  size = strlen (out);
 +
 +  /* Pass 1: figure out how much to allocate by finding all \N strings. */
 +  if (out[size - 1] == '\\')
 +    fatal ("pattern error in \"%s\"", out);
 +  for (t = strchr (out, '\\');
 +       t != NULL;
 +       t = strchr (t + 2, '\\'))
 +    if (ISDIGIT (t[1]))
 +      {
 +	dig = t[1] - '0';
 +	diglen = regs->end[dig] - regs->start[dig];
 +	size += diglen - 2;
 +      }
 +    else
 +      size -= 1;
 +
 +  /* Allocate space and do the substitutions. */
 +  assert (size >= 0);
 +  result = xnew (size + 1, char);
 +
 +  for (t = result; *out != '\0'; out++)
 +    if (*out == '\\' && ISDIGIT (*++out))
 +      {
 +	dig = *out - '0';
 +	diglen = regs->end[dig] - regs->start[dig];
 +	memcpy (t, in + regs->start[dig], diglen);
 +	t += diglen;
 +      }
 +    else
 +      *t++ = *out;
 +  *t = '\0';
 +
 +  assert (t <= result + size);
 +  assert (t - result == (int)strlen (result));
 +
 +  return result;
 +}
 +
 +/* Deallocate all regexps. */
 +static void
 +free_regexps (void)
 +{
 +  regexp *rp;
 +  while (p_head != NULL)
 +    {
 +      rp = p_head->p_next;
 +      free (p_head->pattern);
 +      free (p_head->name);
 +      free (p_head);
 +      p_head = rp;
 +    }
 +  return;
 +}
 +
 +/*
 + * Reads the whole file as a single string from `filebuf' and looks for
 + * multi-line regular expressions, creating tags on matches.
 + * readline already dealt with normal regexps.
 + *
 + * Idea by Ben Wing <ben@666.com> (2002).
 + */
 +static void
 +regex_tag_multiline (void)
 +{
 +  char *buffer = filebuf.buffer;
 +  regexp *rp;
 +  char *name;
 +
 +  for (rp = p_head; rp != NULL; rp = rp->p_next)
 +    {
 +      int match = 0;
 +
 +      if (!rp->multi_line)
 +	continue;		/* skip normal regexps */
 +
 +      /* Generic initializations before parsing file from memory. */
 +      lineno = 1;		/* reset global line number */
 +      charno = 0;		/* reset global char number */
 +      linecharno = 0;		/* reset global char number of line start */
 +
 +      /* Only use generic regexps or those for the current language. */
 +      if (rp->lang != NULL && rp->lang != curfdp->lang)
 +	continue;
 +
 +      while (match >= 0 && match < filebuf.len)
 +	{
 +	  match = re_search (rp->pat, buffer, filebuf.len, charno,
 +			     filebuf.len - match, &rp->regs);
 +	  switch (match)
 +	    {
 +	    case -2:
 +	      /* Some error. */
 +	      if (!rp->error_signaled)
 +		{
 +		  error ("regexp stack overflow while matching \"%s\"",
 +			 rp->pattern);
 +		  rp->error_signaled = true;
 +		}
 +	      break;
 +	    case -1:
 +	      /* No match. */
 +	      break;
 +	    default:
 +	      if (match == rp->regs.end[0])
 +		{
 +		  if (!rp->error_signaled)
 +		    {
 +		      error ("regexp matches the empty string: \"%s\"",
 +			     rp->pattern);
 +		      rp->error_signaled = true;
 +		    }
 +		  match = -3;	/* exit from while loop */
 +		  break;
 +		}
 +
 +	      /* Match occurred.  Construct a tag. */
 +	      while (charno < rp->regs.end[0])
 +		if (buffer[charno++] == '\n')
 +		  lineno++, linecharno = charno;
 +	      name = rp->name;
 +	      if (name[0] == '\0')
 +		name = NULL;
 +	      else /* make a named tag */
 +		name = substitute (buffer, rp->name, &rp->regs);
 +	      if (rp->force_explicit_name)
 +		/* Force explicit tag name, if a name is there. */
 +		pfnote (name, true, buffer + linecharno,
 +			charno - linecharno + 1, lineno, linecharno);
 +	      else
 +		make_tag (name, strlen (name), true, buffer + linecharno,
 +			  charno - linecharno + 1, lineno, linecharno);
 +	      break;
 +	    }
 +	}
 +    }
 +}
 +
 +
 +static bool
 +nocase_tail (const char *cp)
 +{
 +  register int len = 0;
 +
 +  while (*cp != '\0' && lowcase (*cp) == lowcase (dbp[len]))
 +    cp++, len++;
 +  if (*cp == '\0' && !intoken (dbp[len]))
 +    {
 +      dbp += len;
 +      return true;
 +    }
 +  return false;
 +}
 +
 +static void
 +get_tag (register char *bp, char **namepp)
 +{
 +  register char *cp = bp;
 +
 +  if (*bp != '\0')
 +    {
 +      /* Go till you get to white space or a syntactic break */
 +      for (cp = bp + 1; !notinname (*cp); cp++)
 +	continue;
 +      make_tag (bp, cp - bp, true,
 +		lb.buffer, cp - lb.buffer + 1, lineno, linecharno);
 +    }
 +
 +  if (namepp != NULL)
 +    *namepp = savenstr (bp, cp - bp);
 +}
 +
 +/*
 + * Read a line of text from `stream' into `lbp', excluding the
 + * newline or CR-NL, if any.  Return the number of characters read from
 + * `stream', which is the length of the line including the newline.
 + *
 + * On DOS or Windows we do not count the CR character, if any before the
 + * NL, in the returned length; this mirrors the behavior of Emacs on those
 + * platforms (for text files, it translates CR-NL to NL as it reads in the
 + * file).
 + *
 + * If multi-line regular expressions are requested, each line read is
 + * appended to `filebuf'.
 + */
 +static long
 +readline_internal (linebuffer *lbp, register FILE *stream)
 +{
 +  char *buffer = lbp->buffer;
 +  register char *p = lbp->buffer;
 +  register char *pend;
 +  int chars_deleted;
 +
 +  pend = p + lbp->size;		/* Separate to avoid 386/IX compiler bug.  */
 +
 +  for (;;)
 +    {
 +      register int c = getc (stream);
 +      if (p == pend)
 +	{
 +	  /* We're at the end of linebuffer: expand it. */
 +	  lbp->size *= 2;
 +	  xrnew (buffer, lbp->size, char);
 +	  p += buffer - lbp->buffer;
 +	  pend = buffer + lbp->size;
 +	  lbp->buffer = buffer;
 +	}
 +      if (c == EOF)
 +	{
 +	  *p = '\0';
 +	  chars_deleted = 0;
 +	  break;
 +	}
 +      if (c == '\n')
 +	{
 +	  if (p > buffer && p[-1] == '\r')
 +	    {
 +	      p -= 1;
 +#ifdef DOS_NT
 +	     /* Assume CRLF->LF translation will be performed by Emacs
 +		when loading this file, so CRs won't appear in the buffer.
 +		It would be cleaner to compensate within Emacs;
 +		however, Emacs does not know how many CRs were deleted
 +		before any given point in the file.  */
 +	      chars_deleted = 1;
 +#else
 +	      chars_deleted = 2;
 +#endif
 +	    }
 +	  else
 +	    {
 +	      chars_deleted = 1;
 +	    }
 +	  *p = '\0';
 +	  break;
 +	}
 +      *p++ = c;
 +    }
 +  lbp->len = p - buffer;
 +
 +  if (need_filebuf		/* we need filebuf for multi-line regexps */
 +      && chars_deleted > 0)	/* not at EOF */
 +    {
 +      while (filebuf.size <= filebuf.len + lbp->len + 1) /* +1 for \n */
 +	{
 +	  /* Expand filebuf. */
 +	  filebuf.size *= 2;
 +	  xrnew (filebuf.buffer, filebuf.size, char);
 +	}
 +      memcpy (filebuf.buffer + filebuf.len, lbp->buffer, lbp->len);
 +      filebuf.len += lbp->len;
 +      filebuf.buffer[filebuf.len++] = '\n';
 +      filebuf.buffer[filebuf.len] = '\0';
 +    }
 +
 +  return lbp->len + chars_deleted;
 +}
 +
 +/*
 + * Like readline_internal, above, but in addition try to match the
 + * input line against relevant regular expressions and manage #line
 + * directives.
 + */
 +static void
 +readline (linebuffer *lbp, FILE *stream)
 +{
 +  long result;
 +
 +  linecharno = charno;		/* update global char number of line start */
 +  result = readline_internal (lbp, stream); /* read line */
 +  lineno += 1;			/* increment global line number */
 +  charno += result;		/* increment global char number */
 +
 +  /* Honor #line directives. */
 +  if (!no_line_directive)
 +    {
 +      static bool discard_until_line_directive;
 +
 +      /* Check whether this is a #line directive. */
 +      if (result > 12 && strneq (lbp->buffer, "#line ", 6))
 +	{
 +	  unsigned int lno;
 +	  int start = 0;
 +
 +	  if (sscanf (lbp->buffer, "#line %u \"%n", &lno, &start) >= 1
 +	      && start > 0)	/* double quote character found */
 +	    {
 +	      char *endp = lbp->buffer + start;
 +
 +	      while ((endp = strchr (endp, '"')) != NULL
 +		     && endp[-1] == '\\')
 +		endp++;
 +	      if (endp != NULL)
 +		/* Ok, this is a real #line directive.  Let's deal with it. */
 +		{
 +		  char *taggedabsname;	/* absolute name of original file */
 +		  char *taggedfname;	/* name of original file as given */
 +		  char *name;		/* temp var */
 +
 +		  discard_until_line_directive = false; /* found it */
 +		  name = lbp->buffer + start;
 +		  *endp = '\0';
 +		  canonicalize_filename (name);
 +		  taggedabsname = absolute_filename (name, tagfiledir);
 +		  if (filename_is_absolute (name)
 +		      || filename_is_absolute (curfdp->infname))
 +		    taggedfname = savestr (taggedabsname);
 +		  else
 +		    taggedfname = relative_filename (taggedabsname,tagfiledir);
 +
 +		  if (streq (curfdp->taggedfname, taggedfname))
 +		    /* The #line directive is only a line number change.  We
 +		       deal with this afterwards. */
 +		    free (taggedfname);
 +		  else
 +		    /* The tags following this #line directive should be
 +		       attributed to taggedfname.  In order to do this, set
 +		       curfdp accordingly. */
 +		    {
 +		      fdesc *fdp; /* file description pointer */
 +
 +		      /* Go look for a file description already set up for the
 +			 file indicated in the #line directive.  If there is
 +			 one, use it from now until the next #line
 +			 directive. */
 +		      for (fdp = fdhead; fdp != NULL; fdp = fdp->next)
 +			if (streq (fdp->infname, curfdp->infname)
 +			    && streq (fdp->taggedfname, taggedfname))
 +			  /* If we remove the second test above (after the &&)
 +			     then all entries pertaining to the same file are
 +			     coalesced in the tags file.  If we use it, then
 +			     entries pertaining to the same file but generated
 +			     from different files (via #line directives) will
 +			     go into separate sections in the tags file.  These
 +			     alternatives look equivalent.  The first one
 +			     destroys some apparently useless information. */
 +			  {
 +			    curfdp = fdp;
 +			    free (taggedfname);
 +			    break;
 +			  }
 +		      /* Else, if we already tagged the real file, skip all
 +			 input lines until the next #line directive. */
 +		      if (fdp == NULL) /* not found */
 +			for (fdp = fdhead; fdp != NULL; fdp = fdp->next)
 +			  if (streq (fdp->infabsname, taggedabsname))
 +			    {
 +			      discard_until_line_directive = true;
 +			      free (taggedfname);
 +			      break;
 +			    }
 +		      /* Else create a new file description and use that from
 +			 now on, until the next #line directive. */
 +		      if (fdp == NULL) /* not found */
 +			{
 +			  fdp = fdhead;
 +			  fdhead = xnew (1, fdesc);
 +			  *fdhead = *curfdp; /* copy curr. file description */
 +			  fdhead->next = fdp;
 +			  fdhead->infname = savestr (curfdp->infname);
 +			  fdhead->infabsname = savestr (curfdp->infabsname);
 +			  fdhead->infabsdir = savestr (curfdp->infabsdir);
 +			  fdhead->taggedfname = taggedfname;
 +			  fdhead->usecharno = false;
 +			  fdhead->prop = NULL;
 +			  fdhead->written = false;
 +			  curfdp = fdhead;
 +			}
 +		    }
 +		  free (taggedabsname);
 +		  lineno = lno - 1;
 +		  readline (lbp, stream);
 +		  return;
 +		} /* if a real #line directive */
 +	    } /* if #line is followed by a number */
 +	} /* if line begins with "#line " */
 +
 +      /* If we are here, no #line directive was found. */
 +      if (discard_until_line_directive)
 +	{
 +	  if (result > 0)
 +	    {
 +	      /* Do a tail recursion on ourselves, thus discarding the contents
 +		 of the line buffer. */
 +	      readline (lbp, stream);
 +	      return;
 +	    }
 +	  /* End of file. */
 +	  discard_until_line_directive = false;
 +	  return;
 +	}
 +    } /* if #line directives should be considered */
 +
 +  {
 +    int match;
 +    regexp *rp;
 +    char *name;
 +
 +    /* Match against relevant regexps. */
 +    if (lbp->len > 0)
 +      for (rp = p_head; rp != NULL; rp = rp->p_next)
 +	{
 +	  /* Only use generic regexps or those for the current language.
 +	     Also do not use multiline regexps, which is the job of
 +	     regex_tag_multiline. */
 +	  if ((rp->lang != NULL && rp->lang != fdhead->lang)
 +	      || rp->multi_line)
 +	    continue;
 +
 +	  match = re_match (rp->pat, lbp->buffer, lbp->len, 0, &rp->regs);
 +	  switch (match)
 +	    {
 +	    case -2:
 +	      /* Some error. */
 +	      if (!rp->error_signaled)
 +		{
 +		  error ("regexp stack overflow while matching \"%s\"",
 +			 rp->pattern);
 +		  rp->error_signaled = true;
 +		}
 +	      break;
 +	    case -1:
 +	      /* No match. */
 +	      break;
 +	    case 0:
 +	      /* Empty string matched. */
 +	      if (!rp->error_signaled)
 +		{
 +		  error ("regexp matches the empty string: \"%s\"", rp->pattern);
 +		  rp->error_signaled = true;
 +		}
 +	      break;
 +	    default:
 +	      /* Match occurred.  Construct a tag. */
 +	      name = rp->name;
 +	      if (name[0] == '\0')
 +		name = NULL;
 +	      else /* make a named tag */
 +		name = substitute (lbp->buffer, rp->name, &rp->regs);
 +	      if (rp->force_explicit_name)
 +		/* Force explicit tag name, if a name is there. */
 +		pfnote (name, true, lbp->buffer, match, lineno, linecharno);
 +	      else
 +		make_tag (name, strlen (name), true,
 +			  lbp->buffer, match, lineno, linecharno);
 +	      break;
 +	    }
 +	}
 +  }
 +}
 +
 +
 +/*
 + * Return a pointer to a space of size strlen(cp)+1 allocated
 + * with xnew where the string CP has been copied.
 + */
 +static char *
 +savestr (const char *cp)
 +{
 +  return savenstr (cp, strlen (cp));
 +}
 +
 +/*
 + * Return a pointer to a space of size LEN+1 allocated with xnew where
 + * the string CP has been copied for at most the first LEN characters.
 + */
 +static char *
 +savenstr (const char *cp, int len)
 +{
 +  char *dp = xnew (len + 1, char);
 +  dp[len] = '\0';
 +  return memcpy (dp, cp, len);
 +}
 +
 +/* Skip spaces (end of string is not space), return new pointer. */
 +static char *
 +skip_spaces (char *cp)
 +{
 +  while (iswhite (*cp))
 +    cp++;
 +  return cp;
 +}
 +
 +/* Skip non spaces, except end of string, return new pointer. */
 +static char *
 +skip_non_spaces (char *cp)
 +{
 +  while (*cp != '\0' && !iswhite (*cp))
 +    cp++;
 +  return cp;
 +}
 +
 +/* Skip any chars in the "name" class.*/
 +static char *
 +skip_name (char *cp)
 +{
 +  /* '\0' is a notinname() so loop stops there too */
 +  while (! notinname (*cp))
 +    cp++;
 +  return cp;
 +}
 +
 +/* Print error message and exit.  */
 +void
 +fatal (const char *s1, const char *s2)
 +{
 +  error (s1, s2);
 +  exit (EXIT_FAILURE);
 +}
 +
 +static void
 +pfatal (const char *s1)
 +{
 +  perror (s1);
 +  exit (EXIT_FAILURE);
 +}
 +
 +static void
 +suggest_asking_for_help (void)
 +{
 +  fprintf (stderr, "\tTry `%s --help' for a complete list of options.\n",
 +	   progname);
 +  exit (EXIT_FAILURE);
 +}
 +
 +/* Output a diagnostic with printf-style FORMAT and args.  */
 +static void
 +error (const char *format, ...)
 +{
 +  va_list ap;
 +  va_start (ap, format);
 +  fprintf (stderr, "%s: ", progname);
 +  vfprintf (stderr, format, ap);
 +  fprintf (stderr, "\n");
 +  va_end (ap);
 +}
 +
 +/* Return a newly-allocated string whose contents
 +   concatenate those of s1, s2, s3.  */
 +static char *
 +concat (const char *s1, const char *s2, const char *s3)
 +{
 +  int len1 = strlen (s1), len2 = strlen (s2), len3 = strlen (s3);
 +  char *result = xnew (len1 + len2 + len3 + 1, char);
 +
 +  strcpy (result, s1);
 +  strcpy (result + len1, s2);
 +  strcpy (result + len1 + len2, s3);
 +
 +  return result;
 +}
 +
 +
 +/* Does the same work as the system V getcwd, but does not need to
 +   guess the buffer size in advance. */
 +static char *
 +etags_getcwd (void)
 +{
 +  int bufsize = 200;
 +  char *path = xnew (bufsize, char);
 +
 +  while (getcwd (path, bufsize) == NULL)
 +    {
 +      if (errno != ERANGE)
 +	pfatal ("getcwd");
 +      bufsize *= 2;
 +      free (path);
 +      path = xnew (bufsize, char);
 +    }
 +
 +  canonicalize_filename (path);
 +  return path;
 +}
 +
 +/* Return a newly allocated string containing the file name of FILE
 +   relative to the absolute directory DIR (which should end with a slash). */
 +static char *
 +relative_filename (char *file, char *dir)
 +{
 +  char *fp, *dp, *afn, *res;
 +  int i;
 +
 +  /* Find the common root of file and dir (with a trailing slash). */
 +  afn = absolute_filename (file, cwd);
 +  fp = afn;
 +  dp = dir;
 +  while (*fp++ == *dp++)
 +    continue;
 +  fp--, dp--;			/* back to the first differing char */
 +#ifdef DOS_NT
 +  if (fp == afn && afn[0] != '/') /* cannot build a relative name */
 +    return afn;
 +#endif
 +  do				/* look at the equal chars until '/' */
 +    fp--, dp--;
 +  while (*fp != '/');
 +
 +  /* Build a sequence of "../" strings for the resulting relative file name. */
 +  i = 0;
 +  while ((dp = strchr (dp + 1, '/')) != NULL)
 +    i += 1;
 +  res = xnew (3*i + strlen (fp + 1) + 1, char);
 +  char *z = res;
 +  while (i-- > 0)
 +    z = stpcpy (z, "../");
 +
 +  /* Add the file name relative to the common root of file and dir. */
 +  strcpy (z, fp + 1);
 +  free (afn);
 +
 +  return res;
 +}
 +
 +/* Return a newly allocated string containing the absolute file name
 +   of FILE given DIR (which should end with a slash). */
 +static char *
 +absolute_filename (char *file, char *dir)
 +{
 +  char *slashp, *cp, *res;
 +
 +  if (filename_is_absolute (file))
 +    res = savestr (file);
 +#ifdef DOS_NT
 +  /* We don't support non-absolute file names with a drive
 +     letter, like `d:NAME' (it's too much hassle).  */
 +  else if (file[1] == ':')
 +    fatal ("%s: relative file names with drive letters not supported", file);
 +#endif
 +  else
 +    res = concat (dir, file, "");
 +
 +  /* Delete the "/dirname/.." and "/." substrings. */
 +  slashp = strchr (res, '/');
 +  while (slashp != NULL && slashp[0] != '\0')
 +    {
 +      if (slashp[1] == '.')
 +	{
 +	  if (slashp[2] == '.'
 +	      && (slashp[3] == '/' || slashp[3] == '\0'))
 +	    {
 +	      cp = slashp;
 +	      do
 +		cp--;
 +	      while (cp >= res && !filename_is_absolute (cp));
 +	      if (cp < res)
 +		cp = slashp;	/* the absolute name begins with "/.." */
 +#ifdef DOS_NT
 +	      /* Under MSDOS and NT we get `d:/NAME' as absolute
 +		 file name, so the luser could say `d:/../NAME'.
 +		 We silently treat this as `d:/NAME'.  */
 +	      else if (cp[0] != '/')
 +		cp = slashp;
 +#endif
 +              memmove (cp, slashp + 3, strlen (slashp + 2));
 +	      slashp = cp;
 +	      continue;
 +	    }
 +	  else if (slashp[2] == '/' || slashp[2] == '\0')
 +	    {
 +	      memmove (slashp, slashp + 2, strlen (slashp + 1));
 +	      continue;
 +	    }
 +	}
 +
 +      slashp = strchr (slashp + 1, '/');
 +    }
 +
 +  if (res[0] == '\0')		/* just a safety net: should never happen */
 +    {
 +      free (res);
 +      return savestr ("/");
 +    }
 +  else
 +    return res;
 +}
 +
 +/* Return a newly allocated string containing the absolute
 +   file name of dir where FILE resides given DIR (which should
 +   end with a slash). */
 +static char *
 +absolute_dirname (char *file, char *dir)
 +{
 +  char *slashp, *res;
 +  char save;
 +
 +  slashp = strrchr (file, '/');
 +  if (slashp == NULL)
 +    return savestr (dir);
 +  save = slashp[1];
 +  slashp[1] = '\0';
 +  res = absolute_filename (file, dir);
 +  slashp[1] = save;
 +
 +  return res;
 +}
 +
 +/* Whether the argument string is an absolute file name.  The argument
 +   string must have been canonicalized with canonicalize_filename. */
 +static bool
 +filename_is_absolute (char *fn)
 +{
 +  return (fn[0] == '/'
 +#ifdef DOS_NT
 +	  || (ISALPHA (fn[0]) && fn[1] == ':' && fn[2] == '/')
 +#endif
 +	  );
 +}
 +
 +/* Downcase DOS drive letter and collapse separators into single slashes.
 +   Works in place. */
 +static void
 +canonicalize_filename (register char *fn)
 +{
 +  register char* cp;
 +  char sep = '/';
 +
 +#ifdef DOS_NT
 +  /* Canonicalize drive letter case.  */
 +# define ISUPPER(c)	isupper (CHAR (c))
 +  if (fn[0] != '\0' && fn[1] == ':' && ISUPPER (fn[0]))
 +    fn[0] = lowcase (fn[0]);
 +
 +  sep = '\\';
 +#endif
 +
 +  /* Collapse multiple separators into a single slash. */
 +  for (cp = fn; *cp != '\0'; cp++, fn++)
 +    if (*cp == sep)
 +      {
 +	*fn = '/';
 +	while (cp[1] == sep)
 +	  cp++;
 +      }
 +    else
 +      *fn = *cp;
 +  *fn = '\0';
 +}
 +
 +
 +/* Initialize a linebuffer for use. */
 +static void
 +linebuffer_init (linebuffer *lbp)
 +{
 +  lbp->size = (DEBUG) ? 3 : 200;
 +  lbp->buffer = xnew (lbp->size, char);
 +  lbp->buffer[0] = '\0';
 +  lbp->len = 0;
 +}
 +
 +/* Set the minimum size of a string contained in a linebuffer. */
 +static void
 +linebuffer_setlen (linebuffer *lbp, int toksize)
 +{
 +  while (lbp->size <= toksize)
 +    {
 +      lbp->size *= 2;
 +      xrnew (lbp->buffer, lbp->size, char);
 +    }
 +  lbp->len = toksize;
 +}
 +
 +/* Like malloc but get fatal error if memory is exhausted. */
 +static void *
 +xmalloc (size_t size)
 +{
 +  void *result = malloc (size);
 +  if (result == NULL)
 +    fatal ("virtual memory exhausted", (char *)NULL);
 +  return result;
 +}
 +
 +static void *
 +xrealloc (void *ptr, size_t size)
 +{
 +  void *result = realloc (ptr, size);
 +  if (result == NULL)
 +    fatal ("virtual memory exhausted", (char *)NULL);
 +  return result;
 +}
 +
 +/*
 + * Local Variables:
 + * indent-tabs-mode: t
 + * tab-width: 8
 + * fill-column: 79
 + * c-font-lock-extra-types: ("FILE" "bool" "language" "linebuffer" "fdesc" "node" "regexp")
 + * c-file-style: "gnu"
 + * End:
 + */
 +
 +/* etags.c ends here */
diff --cc test/manual/etags/c-src/exit.c
index 86afda9ed01,00000000000..b1952bfddb9
mode 100644,000000..100644
--- a/test/manual/etags/c-src/exit.c
+++ b/test/manual/etags/c-src/exit.c
@@@ -1,77 -1,0 +1,77 @@@
- /* Copyright (C) 1991, 2016 Free Software Foundation, Inc.
++/* Copyright (C) 1991, 2016-2017 Free Software Foundation, Inc.
 +This file is part of the GNU C Library.
 +
 +The GNU C Library is free software; you can redistribute it and/or
 +modify it under the terms of the GNU Library General Public License as
 +published by the Free Software Foundation; either version 2 of the
 +License, or (at your option) any later version.
 +
 +The GNU C Library is distributed in the hope that it will be useful,
 +but WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 +Library General Public License for more details.
 +
 +You should have received a copy of the GNU Library General Public
 +License along with the GNU C Library; see the file COPYING.LIB.  If
 +not, write to the Free Software Foundation, Inc., 675 Mass Ave,
 +Cambridge, MA 02139, USA.  */
 +
 +#include <ansidecl.h>
 +#include <stdio.h>
 +#include <stdlib.h>
 +#include <unistd.h>
 +#include "exit.h"
 +
 +#ifdef	HAVE_GNU_LD
 +CONST struct
 +  {
 +    size_t n;
 +    void EXFUN((*fn[1]), (NOARGS));
 +  } __libc_atexit;
 +#endif
 +
 +/* Call all functions registered with `atexit' and `on_exit',
 +   in the reverse of the order in which they were registered
 +   perform stdio cleanup, and terminate program execution with STATUS.  */
 +__NORETURN
 +void
 +DEFUN(exit, (status), int status)
 +{
 +  register CONST struct exit_function_list *l;
 +
 +  for (l = __exit_funcs; l != NULL; l = l->next)
 +    {
 +      register size_t i = l->idx;
 +      while (i-- > 0)
 +	{
 +	  CONST struct exit_function *CONST f = &l->fns[i];
 +	  switch (f->flavor)
 +	    {
 +	    case ef_free:
 +	      break;
 +	    case ef_on:
 +	      (*f->func.on.fn)(status, f->func.on.arg);
 +	      break;
 +	    case ef_at:
 +	      (*f->func.at)();
 +	      break;
 +	    }
 +	}
 +    }
 +
 +#ifdef	HAVE_GNU_LD
 +  {
 +    void EXFUN((*CONST *fn), (NOARGS));
 +    for (fn = __libc_atexit.fn; *fn != NULL; ++fn)
 +      (**fn) ();
 +  }
 +#else
 +  {
 +    extern void EXFUN(_cleanup, (NOARGS));
 +    _cleanup();
 +  }
 +#endif
 +
 +  _exit(status);
 +}
 +
diff --cc test/manual/etags/c-src/exit.strange_suffix
index 86afda9ed01,00000000000..b1952bfddb9
mode 100644,000000..100644
--- a/test/manual/etags/c-src/exit.strange_suffix
+++ b/test/manual/etags/c-src/exit.strange_suffix
@@@ -1,77 -1,0 +1,77 @@@
- /* Copyright (C) 1991, 2016 Free Software Foundation, Inc.
++/* Copyright (C) 1991, 2016-2017 Free Software Foundation, Inc.
 +This file is part of the GNU C Library.
 +
 +The GNU C Library is free software; you can redistribute it and/or
 +modify it under the terms of the GNU Library General Public License as
 +published by the Free Software Foundation; either version 2 of the
 +License, or (at your option) any later version.
 +
 +The GNU C Library is distributed in the hope that it will be useful,
 +but WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 +Library General Public License for more details.
 +
 +You should have received a copy of the GNU Library General Public
 +License along with the GNU C Library; see the file COPYING.LIB.  If
 +not, write to the Free Software Foundation, Inc., 675 Mass Ave,
 +Cambridge, MA 02139, USA.  */
 +
 +#include <ansidecl.h>
 +#include <stdio.h>
 +#include <stdlib.h>
 +#include <unistd.h>
 +#include "exit.h"
 +
 +#ifdef	HAVE_GNU_LD
 +CONST struct
 +  {
 +    size_t n;
 +    void EXFUN((*fn[1]), (NOARGS));
 +  } __libc_atexit;
 +#endif
 +
 +/* Call all functions registered with `atexit' and `on_exit',
 +   in the reverse of the order in which they were registered
 +   perform stdio cleanup, and terminate program execution with STATUS.  */
 +__NORETURN
 +void
 +DEFUN(exit, (status), int status)
 +{
 +  register CONST struct exit_function_list *l;
 +
 +  for (l = __exit_funcs; l != NULL; l = l->next)
 +    {
 +      register size_t i = l->idx;
 +      while (i-- > 0)
 +	{
 +	  CONST struct exit_function *CONST f = &l->fns[i];
 +	  switch (f->flavor)
 +	    {
 +	    case ef_free:
 +	      break;
 +	    case ef_on:
 +	      (*f->func.on.fn)(status, f->func.on.arg);
 +	      break;
 +	    case ef_at:
 +	      (*f->func.at)();
 +	      break;
 +	    }
 +	}
 +    }
 +
 +#ifdef	HAVE_GNU_LD
 +  {
 +    void EXFUN((*CONST *fn), (NOARGS));
 +    for (fn = __libc_atexit.fn; *fn != NULL; ++fn)
 +      (**fn) ();
 +  }
 +#else
 +  {
 +    extern void EXFUN(_cleanup, (NOARGS));
 +    _cleanup();
 +  }
 +#endif
 +
 +  _exit(status);
 +}
 +
diff --cc test/manual/etags/c-src/getopt.h
index aa2eb1dc173,00000000000..aa66fac4ecd
mode 100644,000000..100644
--- a/test/manual/etags/c-src/getopt.h
+++ b/test/manual/etags/c-src/getopt.h
@@@ -1,125 -1,0 +1,125 @@@
 +/* Declarations for getopt.
-    Copyright (C) 1989-1992, 2016 Free Software Foundation, Inc.
++   Copyright (C) 1989-1992, 2016-2017 Free Software Foundation, Inc.
 +
 +   This program is free software; you can redistribute it and/or modify it
 +   under the terms of the GNU General Public License as published by the
 +   Free Software Foundation; either version 2, or (at your option) any
 +   later version.
 +   
 +   This program is distributed in the hope that it will be useful,
 +   but WITHOUT ANY WARRANTY; without even the implied warranty of
 +   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +   GNU General Public License for more details.
 +   
 +   You should have received a copy of the GNU General Public License
 +   along with this program; if not, write to the Free Software
 +   Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
 +
 +#ifndef _GETOPT_H
 +#define _GETOPT_H 1
 +
 +#ifdef	__cplusplus
 +extern "C" {
 +#endif
 +
 +/* For communication from `getopt' to the caller.
 +   When `getopt' finds an option that takes an argument,
 +   the argument value is returned here.
 +   Also, when `ordering' is RETURN_IN_ORDER,
 +   each non-option ARGV-element is returned here.  */
 +
 +extern char *optarg;
 +
 +/* Index in ARGV of the next element to be scanned.
 +   This is used for communication to and from the caller
 +   and for communication between successive calls to `getopt'.
 +
 +   On entry to `getopt', zero means this is the first call; initialize.
 +
 +   When `getopt' returns EOF, this is the index of the first of the
 +   non-option elements that the caller should itself scan.
 +
 +   Otherwise, `optind' communicates from one call to the next
 +   how much of ARGV has been scanned so far.  */
 +
 +extern int optind;
 +
 +/* Callers store zero here to inhibit the error message `getopt' prints
 +   for unrecognized options.  */
 +
 +extern int opterr;
 +
 +/* Describe the long-named options requested by the application.
 +   The LONG_OPTIONS argument to getopt_long or getopt_long_only is a vector
 +   of `struct option' terminated by an element containing a name which is
 +   zero.
 +
 +   The field `has_arg' is:
 +   no_argument		(or 0) if the option does not take an argument,
 +   required_argument	(or 1) if the option requires an argument,
 +   optional_argument 	(or 2) if the option takes an optional argument.
 +
 +   If the field `flag' is not NULL, it points to a variable that is set
 +   to the value given in the field `val' when the option is found, but
 +   left unchanged if the option is not found.
 +
 +   To have a long-named option do something other than set an `int' to
 +   a compiled-in constant, such as set a value from `optarg', set the
 +   option's `flag' field to zero and its `val' field to a nonzero
 +   value (the equivalent single-letter option character, if there is
 +   one).  For long options that have a zero `flag' field, `getopt'
 +   returns the contents of the `val' field.  */
 +
 +struct option
 +{
 +#if	__STDC__
 +  const char *name;
 +#else
 +  char *name;
 +#endif
 +  /* has_arg can't be an enum because some compilers complain about
 +     type mismatches in all the code that assumes it is an int.  */
 +  int has_arg;
 +  int *flag;
 +  int val;
 +};
 +
 +/* Names for the values of the `has_arg' field of `struct option'.  */
 +
 +#define	no_argument		0
 +#define required_argument	1
 +#define optional_argument	2
 +
 +#if __STDC__
 +#if defined(__GNU_LIBRARY__)
 +/* Many other libraries have conflicting prototypes for getopt, with
 +   differences in the consts, in stdlib.h.  To avoid compilation
 +   errors, only prototype getopt for the GNU C library.  */
 +extern int getopt (int argc, char *const *argv, const char *shortopts);
 +#else /* not __GNU_LIBRARY__ */
 +extern int getopt ();
 +#endif /* not __GNU_LIBRARY__ */
 +extern int getopt_long (int argc, char *const *argv, const char *shortopts,
 +		        const struct option *longopts, int *longind);
 +extern int getopt_long_only (int argc, char *const *argv,
 +			     const char *shortopts,
 +		             const struct option *longopts, int *longind);
 +
 +/* Internal only.  Users should not call this directly.  */
 +extern int _getopt_internal (int argc, char *const *argv,
 +			     const char *shortopts,
 +		             const struct option *longopts, int *longind,
 +			     int long_only);
 +#else /* not __STDC__ */
 +extern int getopt ();
 +extern int getopt_long ();
 +extern int getopt_long_only ();
 +
 +extern int _getopt_internal ();
 +#endif /* not __STDC__ */
 +
 +#ifdef	__cplusplus
 +}
 +#endif
 +
 +#endif /* _GETOPT_H */
diff --cc test/manual/etags/c-src/sysdep.h
index 6409fcc1e1d,00000000000..2c121cf53a9
mode 100644,000000..100644
--- a/test/manual/etags/c-src/sysdep.h
+++ b/test/manual/etags/c-src/sysdep.h
@@@ -1,57 -1,0 +1,57 @@@
- /* Copyright (C) 1992-1993, 2016 Free Software Foundation, Inc.
++/* Copyright (C) 1992-1993, 2016-2017 Free Software Foundation, Inc.
 +This file is part of the GNU C Library.
 +
 +The GNU C Library is free software; you can redistribute it and/or
 +modify it under the terms of the GNU Library General Public License as
 +published by the Free Software Foundation; either version 2 of the
 +License, or (at your option) any later version.
 +
 +The GNU C Library is distributed in the hope that it will be useful,
 +but WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 +Library General Public License for more details.
 +
 +You should have received a copy of the GNU Library General Public
 +License along with the GNU C Library; see the file COPYING.LIB.  If
 +not, write to the Free Software Foundation, Inc., 675 Mass Ave,
 +Cambridge, MA 02139, USA.  */
 +
 +#include <sysdeps/unix/sysdep.h>
 +
 +#define	ENTRY(name)							      \
 +  .globl _##name;							      \
 +  .align 2;								      \
 +  _##name##:
 +
 +#define	PSEUDO(name, syscall_name, args)				      \
 +  .text;								      \
 +  .globl syscall_error;							      \
 +  ENTRY (name)								      \
 +    XCHG_##args
 +    movl $SYS_##syscall_name, %eax;					      \
 +    int $0x80;								      \
 +    test %eax, %eax;							      \
 +    jl syscall_error;							      \
 +    XCHG_##args
 +
 +/* Linux takes system call arguments in registers:
 +   	1: %ebx
 +	2: %ecx
 +	3: %edx
 +	4: %esi
 +	5: %edi
 +   We put the arguments into registers from the stack,
 +   and save the registers, by using the 386 `xchg' instruction
 +   to swap the values in both directions.  */
 +
 +#define	XCHG_0	/* No arguments to frob.  */
 +#define	XCHG_1	xchg 8(%esp), %ebx; XCHG_0
 +#define	XCHG_2	xchg 12(%esp), %ecx; XCHG_1
 +#define	XCHG_3	xchg 16(%esp), %edx; XCHG_2
 +#define	XCHG_4	xchg 20(%esp), %esi; XCHG_3
 +#define	XCHG_5	xchg 24(%esp), %edi; XCHG_3
 +
 +#define	r0		%eax	/* Normal return-value register.  */
 +#define	r1		%edx	/* Secondary return-value register.  */
 +#define scratch 	%ecx	/* Call-clobbered register for random use.  */
 +#define MOVE(x,y)	movl x, y
diff --cc test/manual/etags/el-src/emacs/lisp/progmodes/etags.el
index 5d28657e28b,00000000000..955859803df
mode 100644,000000..100644
--- a/test/manual/etags/el-src/emacs/lisp/progmodes/etags.el
+++ b/test/manual/etags/el-src/emacs/lisp/progmodes/etags.el
@@@ -1,2153 -1,0 +1,2153 @@@
 +;;; etags.el --- etags facility for Emacs  -*- lexical-binding: t -*-
 +
- ;; Copyright (C) 1985-1986, 1988-1989, 1992-1996, 1998, 2000-2016 Free
++;; Copyright (C) 1985-1986, 1988-1989, 1992-1996, 1998, 2000-2017 Free
 +;; Software Foundation, Inc.
 +
 +;; Author: Roland McGrath <roland@gnu.org>
 +;; Maintainer: emacs-devel@gnu.org
 +;; Keywords: tools
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 +
 +;;; Commentary:
 +
 +;;; Code:
 +
 +(require 'ring)
 +(require 'button)
 +(require 'xref)
 +
 +;;;###autoload
 +(defvar tags-file-name nil
 +  "File name of tags table.
 +To switch to a new tags table, setting this variable is sufficient.
 +If you set this variable, do not also set `tags-table-list'.
 +Use the `etags' program to make a tags table file.")
 +;; Make M-x set-variable tags-file-name like M-x visit-tags-table.
 +;;;###autoload (put 'tags-file-name 'variable-interactive (purecopy "fVisit tags table: "))
 +;;;###autoload (put 'tags-file-name 'safe-local-variable 'stringp)
 +
 +(defgroup etags nil "Tags tables."
 +  :group 'tools)
 +
 +;;;###autoload
 +(defcustom tags-case-fold-search 'default
 +  "Whether tags operations should be case-sensitive.
 +A value of t means case-insensitive, a value of nil means case-sensitive.
 +Any other value means use the setting of `case-fold-search'."
 +  :group 'etags
 +  :type '(choice (const :tag "Case-sensitive" nil)
 +		 (const :tag "Case-insensitive" t)
 +		 (other :tag "Use default" default))
 +  :version "21.1")
 +
 +;;;###autoload
 +;; Use `visit-tags-table-buffer' to cycle through tags tables in this list.
 +(defcustom tags-table-list nil
 +  "List of file names of tags tables to search.
 +An element that is a directory means the file \"TAGS\" in that directory.
 +To switch to a new list of tags tables, setting this variable is sufficient.
 +If you set this variable, do not also set `tags-file-name'.
 +Use the `etags' program to make a tags table file."
 +  :group 'etags
 +  :type '(repeat file))
 +
 +;;;###autoload
 +(defcustom tags-compression-info-list
 +  (purecopy '("" ".Z" ".bz2" ".gz" ".xz" ".tgz"))
 +  "List of extensions tried by etags when `auto-compression-mode' is on.
 +An empty string means search the non-compressed file."
 +  :version "24.1"			; added xz
 +  :type  '(repeat string)
 +  :group 'etags)
 +
 +;; !!! tags-compression-info-list should probably be replaced by access
 +;; to directory list and matching jka-compr-compression-info-list. Currently,
 +;; this implementation forces each modification of
 +;; jka-compr-compression-info-list to be reflected in this var.
 +;; An alternative could be to say that introducing a special
 +;; element in this list (e.g. t) means : try at this point
 +;; using directory listing and regexp matching using
 +;; jka-compr-compression-info-list.
 +
 +
 +;;;###autoload
 +(defcustom tags-add-tables 'ask-user
 +  "Control whether to add a new tags table to the current list.
 +t means do; nil means don't (always start a new list).
 +Any other value means ask the user whether to add a new tags table
 +to the current list (as opposed to starting a new list)."
 +  :group 'etags
 +  :type '(choice (const :tag "Do" t)
 +		 (const :tag "Don't" nil)
 +		 (other :tag "Ask" ask-user)))
 +
 +(defcustom tags-revert-without-query nil
 +  "Non-nil means reread a TAGS table without querying, if it has changed."
 +  :group 'etags
 +  :type 'boolean)
 +
 +(defvar tags-table-computed-list nil
 +  "List of tags tables to search, computed from `tags-table-list'.
 +This includes tables implicitly included by other tables.  The list is not
 +always complete: the included tables of a table are not known until that
 +table is read into core.  An element that is t is a placeholder
 +indicating that the preceding element is a table that has not been read
 +into core and might contain included tables to search.
 +See `tags-table-check-computed-list'.")
 +
 +(defvar tags-table-computed-list-for nil
 +  "Value of `tags-table-list' that `tags-table-computed-list' corresponds to.
 +If `tags-table-list' changes, `tags-table-computed-list' is thrown away and
 +recomputed; see `tags-table-check-computed-list'.")
 +
 +(defvar tags-table-list-pointer nil
 +  "Pointer into `tags-table-computed-list' for the current state of searching.
 +Use `visit-tags-table-buffer' to cycle through tags tables in this list.")
 +
 +(defvar tags-table-list-started-at nil
 +  "Pointer into `tags-table-computed-list', where the current search started.")
 +
 +(defvar tags-table-set-list nil
 +  "List of sets of tags table which have been used together in the past.
 +Each element is a list of strings which are file names.")
 +
 +;;;###autoload
 +(defcustom find-tag-hook nil
 +  "Hook to be run by \\[find-tag] after finding a tag.  See `run-hooks'.
 +The value in the buffer in which \\[find-tag] is done is used,
 +not the value in the buffer \\[find-tag] goes to."
 +  :group 'etags
 +  :type 'hook)
 +
 +;;;###autoload
 +(defcustom find-tag-default-function nil
 +  "A function of no arguments used by \\[find-tag] to pick a default tag.
 +If nil, and the symbol that is the value of `major-mode'
 +has a `find-tag-default-function' property (see `put'), that is used.
 +Otherwise, `find-tag-default' is used."
 +  :group 'etags
 +  :type '(choice (const nil) function))
 +
 +(define-obsolete-variable-alias 'find-tag-marker-ring-length
 +  'xref-marker-ring-length "25.1")
 +
 +(defcustom tags-tag-face 'default
 +  "Face for tags in the output of `tags-apropos'."
 +  :group 'etags
 +  :type 'face
 +  :version "21.1")
 +
 +(defcustom tags-apropos-verbose nil
 +  "If non-nil, print the name of the tags file in the *Tags List* buffer."
 +  :group 'etags
 +  :type 'boolean
 +  :version "21.1")
 +
 +(defcustom tags-apropos-additional-actions nil
 +  "Specify additional actions for `tags-apropos'.
 +
 +If non-nil, value should be a list of triples (TITLE FUNCTION
 +TO-SEARCH).  For each triple, `tags-apropos' processes TO-SEARCH and
 +lists tags from it.  TO-SEARCH should be an alist, obarray, or symbol.
 +If it is a symbol, the symbol's value is used.
 +TITLE, a string, is a title used to label the additional list of tags.
 +FUNCTION is a function to call when a symbol is selected in the
 +*Tags List* buffer.  It will be called with one argument SYMBOL which
 +is the symbol being selected.
 +
 +Example value:
 +
 +  '((\"Emacs Lisp\" Info-goto-emacs-command-node obarray)
 +    (\"Common Lisp\" common-lisp-hyperspec common-lisp-hyperspec-obarray)
 +    (\"SCWM\" scwm-documentation scwm-obarray))"
 +  :group 'etags
 +  :type '(repeat (list (string :tag "Title")
 +		       function
 +		       (sexp :tag "Tags to search")))
 +  :version "21.1")
 +
 +(defvaralias 'find-tag-marker-ring 'xref--marker-ring)
 +(make-obsolete-variable
 + 'find-tag-marker-ring
 + "use `xref-push-marker-stack' or `xref-pop-marker-stack' instead."
 + "25.1")
 +
 +(defvar default-tags-table-function nil
 +  "If non-nil, a function to choose a default tags file for a buffer.
 +This function receives no arguments and should return the default
 +tags table file to use for the current buffer.")
 +
 +(defvar tags-location-ring (make-ring xref-marker-ring-length)
 +  "Ring of markers which are locations visited by \\[find-tag].
 +Pop back to the last location with \\[negative-argument] \\[find-tag].")
 +
 +;; Tags table state.
 +;; These variables are local in tags table buffers.
 +
 +(defvar tags-table-files nil
 +  "List of file names covered by current tags table.
 +nil means it has not yet been computed;
 +use function `tags-table-files' to do so.")
 +
 +(defvar tags-completion-table nil
 +  "Obarray of tag names defined in current tags table.")
 +
 +(defvar tags-included-tables nil
 +  "List of tags tables included by the current tags table.")
 +
 +(defvar next-file-list nil
 +  "List of files for \\[next-file] to process.")
 +
 +;; Hooks for file formats.
 +
 +(defvar tags-table-format-functions '(etags-recognize-tags-table
 +				      tags-recognize-empty-tags-table)
 +  "Hook to be called in a tags table buffer to identify the type of tags table.
 +The functions are called in order, with no arguments,
 +until one returns non-nil.  The function should make buffer-local bindings
 +of the format-parsing tags function variables if successful.")
 +
 +(defvar file-of-tag-function nil
 +  "Function to do the work of `file-of-tag' (which see).
 +One optional argument, a boolean specifying to return complete path (nil) or
 +relative path (non-nil).")
 +(defvar tags-table-files-function nil
 +  "Function to do the work of function `tags-table-files' (which see).")
 +(defvar tags-completion-table-function nil
 +  "Function to build the `tags-completion-table'.")
 +(defvar snarf-tag-function nil
 +  "Function to get info about a matched tag for `goto-tag-location-function'.
 +One optional argument, specifying to use explicit tag (non-nil) or not (nil).
 +The default is nil.")
 +(defvar goto-tag-location-function nil
 +  "Function of to go to the location in the buffer specified by a tag.
 +One argument, the tag info returned by `snarf-tag-function'.")
 +(defvar find-tag-regexp-search-function nil
 +  "Search function passed to `find-tag-in-order' for finding a regexp tag.")
 +(defvar find-tag-regexp-tag-order nil
 +  "Tag order passed to `find-tag-in-order' for finding a regexp tag.")
 +(defvar find-tag-regexp-next-line-after-failure-p nil
 +  "Flag passed to `find-tag-in-order' for finding a regexp tag.")
 +(defvar find-tag-search-function nil
 +  "Search function passed to `find-tag-in-order' for finding a tag.")
 +(defvar find-tag-tag-order nil
 +  "Tag order passed to `find-tag-in-order' for finding a tag.")
 +(defvar find-tag-next-line-after-failure-p nil
 +  "Flag passed to `find-tag-in-order' for finding a tag.")
 +(defvar list-tags-function nil
 +  "Function to do the work of `list-tags' (which see).")
 +(defvar tags-apropos-function nil
 +  "Function to do the work of `tags-apropos' (which see).")
 +(defvar tags-included-tables-function nil
 +  "Function to do the work of function `tags-included-tables' (which see).")
 +(defvar verify-tags-table-function nil
 +  "Function to return t if current buffer contains valid tags file.")
 +
 +(defun initialize-new-tags-table ()
 +  "Initialize the tags table in the current buffer.
 +Return non-nil if it is a valid tags table, and
 +in that case, also make the tags table state variables
 +buffer-local and set them to nil."
 +  (set (make-local-variable 'tags-table-files) nil)
 +  (set (make-local-variable 'tags-completion-table) nil)
 +  (set (make-local-variable 'tags-included-tables) nil)
 +  ;; We used to initialize find-tag-marker-ring and tags-location-ring
 +  ;; here, to new empty rings.  But that is wrong, because those
 +  ;; are global.
 +
 +  ;; Value is t if we have found a valid tags table buffer.
 +  (run-hook-with-args-until-success 'tags-table-format-functions))
 +
 +;;;###autoload
 +(defun tags-table-mode ()
 +  "Major mode for tags table file buffers."
 +  (interactive)
 +  (setq major-mode 'tags-table-mode     ;FIXME: Use define-derived-mode.
 +        mode-name "Tags Table"
 +        buffer-undo-list t)
 +  (initialize-new-tags-table))
 +
 +;;;###autoload
 +(defun visit-tags-table (file &optional local)
 +  "Tell tags commands to use tags table file FILE.
 +FILE should be the name of a file created with the `etags' program.
 +A directory name is ok too; it means file TAGS in that directory.
 +
 +Normally \\[visit-tags-table] sets the global value of `tags-file-name'.
 +With a prefix arg, set the buffer-local value instead.
 +When you find a tag with \\[find-tag], the buffer it finds the tag
 +in is given a local value of this variable which is the name of the tags
 +file the tag was in."
 +  (interactive (list (read-file-name "Visit tags table (default TAGS): "
 +				     default-directory
 +				     (expand-file-name "TAGS"
 +						       default-directory)
 +				     t)
 +		     current-prefix-arg))
 +  (or (stringp file) (signal 'wrong-type-argument (list 'stringp file)))
 +  ;; Bind tags-file-name so we can control below whether the local or
 +  ;; global value gets set.
 +  ;; Calling visit-tags-table-buffer with tags-file-name set to FILE will
 +  ;; initialize a buffer for FILE and set tags-file-name to the
 +  ;; fully-expanded name.
 +  (let ((tags-file-name file))
 +    (save-excursion
 +      (or (visit-tags-table-buffer file)
 +	  (signal 'file-error (list "Visiting tags table"
 +				    "No such file or directory"
 +				    file)))
 +      ;; Set FILE to the expanded name.
 +      (setq file tags-file-name)))
 +  (if local
 +      ;; Set the local value of tags-file-name.
 +      (set (make-local-variable 'tags-file-name) file)
 +    ;; Set the global value of tags-file-name.
 +    (setq-default tags-file-name file)))
 +
 +(defun tags-table-check-computed-list ()
 +  "Compute `tags-table-computed-list' from `tags-table-list' if necessary."
 +  (let ((expanded-list (mapcar 'tags-expand-table-name tags-table-list)))
 +    (or (equal tags-table-computed-list-for expanded-list)
 +	;; The list (or default-directory) has changed since last computed.
 +	(let* ((compute-for (mapcar 'copy-sequence expanded-list))
 +	       (tables (copy-sequence compute-for)) ;Mutated in the loop.
 +	       (computed nil)
 +	       table-buffer)
 +
 +	  (while tables
 +	    (setq computed (cons (car tables) computed)
 +		  table-buffer (get-file-buffer (car tables)))
 +	    (if (and table-buffer
 +		     ;; There is a buffer visiting the file.  Now make sure
 +		     ;; it is initialized as a tag table buffer.
 +		     (save-excursion
 +		       (tags-verify-table (buffer-file-name table-buffer))))
 +		(with-current-buffer table-buffer
 +                  ;; Needed so long as etags-tags-included-tables
 +                  ;; does not save-excursion.
 +                  (save-excursion
 +                    (if (tags-included-tables)
 +                        ;; Insert the included tables into the list we
 +                        ;; are processing.
 +                        (setcdr tables (nconc (mapcar 'tags-expand-table-name
 +                                                      (tags-included-tables))
 +                                              (cdr tables))))))
 +	      ;; This table is not in core yet.  Insert a placeholder
 +	      ;; saying we must read it into core to check for included
 +	      ;; tables before searching the next table in the list.
 +	      (setq computed (cons t computed)))
 +	    (setq tables (cdr tables)))
 +
 +	  ;; Record the tags-table-list value (and the context of the
 +	  ;; current directory) we computed from.
 +	  (setq tags-table-computed-list-for compute-for
 +		tags-table-computed-list (nreverse computed))))))
 +
 +(defun tags-table-extend-computed-list ()
 +  "Extend `tags-table-computed-list' to remove the first t placeholder.
 +
 +An element of the list that is t is a placeholder indicating that the
 +preceding element is a table that has not been read in and might
 +contain included tables to search.  This function reads in the first
 +such table and puts its included tables into the list."
 +  (let ((list tags-table-computed-list))
 +    (while (not (eq (nth 1 list) t))
 +      (setq list (cdr list)))
 +    (save-excursion
 +      (if (tags-verify-table (car list))
 +	  ;; We are now in the buffer visiting (car LIST).  Extract its
 +	  ;; list of included tables and insert it into the computed list.
 +	  (let ((tables (tags-included-tables))
 +		(computed nil)
 +		table-buffer)
 +	    (while tables
 +	      (setq computed (cons (car tables) computed)
 +		    table-buffer (get-file-buffer (car tables)))
 +	      (if table-buffer
 +		  (with-current-buffer table-buffer
 +		    (if (tags-included-tables)
 +			;; Insert the included tables into the list we
 +			;; are processing.
 +			(setcdr tables (append (tags-included-tables)
 +					       tables))))
 +		;; This table is not in core yet.  Insert a placeholder
 +		;; saying we must read it into core to check for included
 +		;; tables before searching the next table in the list.
 +		(setq computed (cons t computed)))
 +	      (setq tables (cdr tables)))
 +	    (setq computed (nreverse computed))
 +	    ;; COMPUTED now contains the list of included tables (and
 +	    ;; tables included by them, etc.).  Now splice this into the
 +	    ;; current list.
 +	    (setcdr list (nconc computed (cdr (cdr list)))))
 +	;; It was not a valid table, so just remove the following placeholder.
 +	(setcdr list (cdr (cdr list)))))))
 +
 +(defun tags-expand-table-name (file)
 +  "Expand tags table name FILE into a complete file name."
 +  (setq file (expand-file-name file))
 +  (if (file-directory-p file)
 +      (expand-file-name "TAGS" file)
 +    file))
 +
 +;; Like member, but comparison is done after tags-expand-table-name on both
 +;; sides and elements of LIST that are t are skipped.
 +(defun tags-table-list-member (file list)
 +  "Like (member FILE LIST) after applying `tags-expand-table-name'.
 +More precisely, apply `tags-expand-table-name' to FILE
 +and each element of LIST, returning the link whose car is the first match.
 +If an element of LIST is t, ignore it."
 +  (setq file (tags-expand-table-name file))
 +  (while (and list
 +	      (or (eq (car list) t)
 +		  (not (string= file (tags-expand-table-name (car list))))))
 +    (setq list (cdr list)))
 +  list)
 +
 +(defun tags-verify-table (file)
 +  "Read FILE into a buffer and verify that it is a valid tags table.
 +Sets the current buffer to one visiting FILE (if it exists).
 +Returns non-nil if it is a valid table."
 +  (if (get-file-buffer file)
 +      ;; The file is already in a buffer.  Check for the visited file
 +      ;; having changed since we last used it.
 +      (progn
 +	(set-buffer (get-file-buffer file))
 +        (or verify-tags-table-function (tags-table-mode))
 +	(if (or (verify-visited-file-modtime (current-buffer))
 +		;; Decide whether to revert the file.
 +		;; revert-without-query can say to revert
 +		;; or the user can say to revert.
 +		(not (or (let ((tail revert-without-query)
 +			       (found nil))
 +			   (while tail
 +			     (if (string-match (car tail) buffer-file-name)
 +				 (setq found t))
 +			     (setq tail (cdr tail)))
 +			   found)
 +			 tags-revert-without-query
 +			 (yes-or-no-p
 +			  (format "Tags file %s has changed, read new contents? "
 +				  file)))))
 +	    (and verify-tags-table-function
 +		 (funcall verify-tags-table-function))
 +	  (revert-buffer t t)
 +	  (tags-table-mode)))
 +    (when (file-exists-p file)
 +      (let* ((buf (find-file-noselect file))
 +             (newfile (buffer-file-name buf)))
 +        (unless (string= file newfile)
 +          ;; find-file-noselect has changed the file name.
 +          ;; Propagate the change to tags-file-name and tags-table-list.
 +          (let ((tail (member file tags-table-list)))
 +            (if tail (setcar tail newfile)))
 +          (if (eq file tags-file-name) (setq tags-file-name newfile)))
 +        ;; Only change buffer now that we're done using potentially
 +        ;; buffer-local variables.
 +        (set-buffer buf)
 +        (tags-table-mode)))))
 +
 +;; Subroutine of visit-tags-table-buffer.  Search the current tags tables
 +;; for one that has tags for THIS-FILE (or that includes a table that
 +;; does).  Return the name of the first table listing THIS-FILE; if
 +;; the table is one included by another table, it is the master table that
 +;; we return.  If CORE-ONLY is non-nil, check only tags tables that are
 +;; already in buffers--don't visit any new files.
 +(defun tags-table-including (this-file core-only)
 +  "Search current tags tables for tags for THIS-FILE.
 +Subroutine of `visit-tags-table-buffer'.
 +Looks for a tags table that has such tags or that includes a table
 +that has them.  Returns the name of the first such table.
 +Non-nil CORE-ONLY means check only tags tables that are already in
 +buffers.  If CORE-ONLY is nil, it is ignored."
 +  (let ((tables tags-table-computed-list)
 +	(found nil))
 +    ;; Loop over the list, looking for a table containing tags for THIS-FILE.
 +    (while (and (not found)
 +		tables)
 +
 +      (if core-only
 +	  ;; Skip tables not in core.
 +	  (while (eq (nth 1 tables) t)
 +	    (setq tables (cdr (cdr tables))))
 +	(if (eq (nth 1 tables) t)
 +	    ;; This table has not been read into core yet.  Read it in now.
 +	    (tags-table-extend-computed-list)))
 +
 +      (if tables
 +	  ;; Select the tags table buffer and get the file list up to date.
 +	  (let ((tags-file-name (car tables)))
 +	    (visit-tags-table-buffer 'same)
 +	    (if (member this-file (mapcar 'expand-file-name
 +					  (tags-table-files)))
 +		;; Found it.
 +		(setq found tables))))
 +      (setq tables (cdr tables)))
 +    (if found
 +	;; Now determine if the table we found was one included by another
 +	;; table, not explicitly listed.  We do this by checking each
 +	;; element of the computed list to see if it appears in the user's
 +	;; explicit list; the last element we will check is FOUND itself.
 +	;; Then we return the last one which did in fact appear in
 +	;; tags-table-list.
 +	(let ((could-be nil)
 +	      (elt tags-table-computed-list))
 +	  (while (not (eq elt (cdr found)))
 +	    (if (tags-table-list-member (car elt) tags-table-list)
 +		;; This table appears in the user's list, so it could be
 +		;; the one which includes the table we found.
 +		(setq could-be (car elt)))
 +	    (setq elt (cdr elt))
 +	    (if (eq t (car elt))
 +		(setq elt (cdr elt))))
 +	  ;; The last element we found in the computed list before FOUND
 +	  ;; that appears in the user's list will be the table that
 +	  ;; included the one we found.
 +	  could-be))))
 +
 +(defun tags-next-table ()
 +  "Move `tags-table-list-pointer' along and set `tags-file-name'.
 +Subroutine of `visit-tags-table-buffer'.\
 +Returns nil when out of tables."
 +  ;; If there is a placeholder element next, compute the list to replace it.
 +  (while (eq (nth 1 tags-table-list-pointer) t)
 +    (tags-table-extend-computed-list))
 +
 +  ;; Go to the next table in the list.
 +  (setq tags-table-list-pointer (cdr tags-table-list-pointer))
 +  (or tags-table-list-pointer
 +      ;; Wrap around.
 +      (setq tags-table-list-pointer tags-table-computed-list))
 +
 +  (if (eq tags-table-list-pointer tags-table-list-started-at)
 +      ;; We have come full circle.  No more tables.
 +      (setq tags-table-list-pointer nil)
 +    ;; Set tags-file-name to the name from the list.  It is already expanded.
 +    (setq tags-file-name (car tags-table-list-pointer))))
 +
 +;;;###autoload
 +(defun visit-tags-table-buffer (&optional cont)
 +  "Select the buffer containing the current tags table.
 +If optional arg is a string, visit that file as a tags table.
 +If optional arg is t, visit the next table in `tags-table-list'.
 +If optional arg is the atom `same', don't look for a new table;
 + just select the buffer visiting `tags-file-name'.
 +If arg is nil or absent, choose a first buffer from information in
 + `tags-file-name', `tags-table-list', `tags-table-list-pointer'.
 +Returns t if it visits a tags table, or nil if there are no more in the list."
 +
 +  ;; Set tags-file-name to the tags table file we want to visit.
 +  (cond ((eq cont 'same)
 +	 ;; Use the ambient value of tags-file-name.
 +	 (or tags-file-name
 +	     (user-error "%s"
 +                         (substitute-command-keys
 +                          (concat "No tags table in use; "
 +                                  "use \\[visit-tags-table] to select one")))))
 +	((eq t cont)
 +	 ;; Find the next table.
 +	 (if (tags-next-table)
 +	     ;; Skip over nonexistent files.
 +	     (while (and (not (or (get-file-buffer tags-file-name)
 +				  (file-exists-p tags-file-name)))
 +			 (tags-next-table)))))
 +	(t
 +	 ;; Pick a table out of our hat.
 +	 (tags-table-check-computed-list) ;Get it up to date, we might use it.
 +	 (setq tags-file-name
 +	       (or
 +		;; If passed a string, use that.
 +		(if (stringp cont)
 +		    (prog1 cont
 +		      (setq cont nil)))
 +		;; First, try a local variable.
 +		(cdr (assq 'tags-file-name (buffer-local-variables)))
 +		;; Second, try a user-specified function to guess.
 +		(and default-tags-table-function
 +		     (funcall default-tags-table-function))
 +		;; Third, look for a tags table that contains tags for the
 +		;; current buffer's file.  If one is found, the lists will
 +		;; be frobnicated, and CONT will be set non-nil so we don't
 +		;; do it below.
 +		(and buffer-file-name
 +		     (or
 +		      ;; First check only tables already in buffers.
 +		      (tags-table-including buffer-file-name t)
 +		      ;; Since that didn't find any, now do the
 +		      ;; expensive version: reading new files.
 +		      (tags-table-including buffer-file-name nil)))
 +		;; Fourth, use the user variable tags-file-name, if it is
 +		;; not already in the current list.
 +		(and tags-file-name
 +		     (not (tags-table-list-member tags-file-name
 +						  tags-table-computed-list))
 +		     tags-file-name)
 +		;; Fifth, use the user variable giving the table list.
 +		;; Find the first element of the list that actually exists.
 +		(let ((list tags-table-list)
 +		      file)
 +		  (while (and list
 +			      (setq file (tags-expand-table-name (car list)))
 +			      (not (get-file-buffer file))
 +			      (not (file-exists-p file)))
 +		    (setq list (cdr list)))
 +		  (car list))
 +		;; Finally, prompt the user for a file name.
 +		(expand-file-name
 +		 (read-file-name "Visit tags table (default TAGS): "
 +				 default-directory
 +				 "TAGS"
 +				 t))))))
 +
 +  ;; Expand the table name into a full file name.
 +  (setq tags-file-name (tags-expand-table-name tags-file-name))
 +
 +  (unless (and (eq cont t) (null tags-table-list-pointer))
 +    ;; Verify that tags-file-name names a valid tags table.
 +    ;; Bind another variable with the value of tags-file-name
 +    ;; before we switch buffers, in case tags-file-name is buffer-local.
 +    (let ((curbuf (current-buffer))
 +	  (local-tags-file-name tags-file-name))
 +      (if (tags-verify-table local-tags-file-name)
 +
 +	  ;; We have a valid tags table.
 +	  (progn
 +	    ;; Bury the tags table buffer so it
 +	    ;; doesn't get in the user's way.
 +	    (bury-buffer (current-buffer))
 +
 +	    ;; If this was a new table selection (CONT is nil), make
 +	    ;; sure tags-table-list includes the chosen table, and
 +	    ;; update the list pointer variables.
 +	    (or cont
 +		;; Look in the list for the table we chose.
 +		(let ((found (tags-table-list-member
 +			      local-tags-file-name
 +			      tags-table-computed-list)))
 +		  (if found
 +		      ;; There it is.  Just switch to it.
 +		      (setq tags-table-list-pointer found
 +			    tags-table-list-started-at found)
 +
 +		    ;; The table is not in the current set.
 +		    ;; Try to find it in another previously used set.
 +		    (let ((sets tags-table-set-list))
 +		      (while (and sets
 +				  (not (tags-table-list-member
 +					local-tags-file-name
 +					(car sets))))
 +			(setq sets (cdr sets)))
 +		      (if sets
 +			  ;; Found in some other set.  Switch to that set.
 +			  (progn
 +			    (or (memq tags-table-list tags-table-set-list)
 +				;; Save the current list.
 +				(setq tags-table-set-list
 +				      (cons tags-table-list
 +					    tags-table-set-list)))
 +			    (setq tags-table-list (car sets)))
 +
 +			;; Not found in any existing set.
 +			(if (and tags-table-list
 +				 (or (eq t tags-add-tables)
 +				     (and tags-add-tables
 +					  (y-or-n-p
 +					   (concat "Keep current list of "
 +						   "tags tables also? ")))))
 +			    ;; Add it to the current list.
 +			    (setq tags-table-list (cons local-tags-file-name
 +							tags-table-list))
 +
 +			  ;; Make a fresh list, and store the old one.
 +			  (message "Starting a new list of tags tables")
 +			  (or (null tags-table-list)
 +			      (memq tags-table-list tags-table-set-list)
 +			      (setq tags-table-set-list
 +				    (cons tags-table-list
 +					  tags-table-set-list)))
 +			  ;; Clear out buffers holding old tables.
 +			  (dolist (table tags-table-list)
 +			    ;; The list can contain items t.
 +			    (if (stringp table)
 +				(let ((buffer (find-buffer-visiting table)))
 +			      (if buffer
 +				  (kill-buffer buffer)))))
 +			  (setq tags-table-list (list local-tags-file-name))))
 +
 +		      ;; Recompute tags-table-computed-list.
 +		      (tags-table-check-computed-list)
 +		      ;; Set the tags table list state variables to start
 +		      ;; over from tags-table-computed-list.
 +		      (setq tags-table-list-started-at tags-table-computed-list
 +			    tags-table-list-pointer
 +			    tags-table-computed-list)))))
 +
 +	    ;; Return of t says the tags table is valid.
 +	    t)
 +
 +	;; The buffer was not valid.  Don't use it again.
 +	(set-buffer curbuf)
 +	(kill-local-variable 'tags-file-name)
 +	(if (eq local-tags-file-name tags-file-name)
 +	    (setq tags-file-name nil))
 +	(user-error (if (file-exists-p local-tags-file-name)
 +                        "File %s is not a valid tags table"
 +                      "File %s does not exist")
 +                    local-tags-file-name)))))
 +
 +(defun tags-reset-tags-tables ()
 +  "Reset tags state to cancel effect of any previous \\[visit-tags-table] or \\[find-tag]."
 +  (interactive)
 +  ;; Clear out the markers we are throwing away.
 +  (let ((i 0))
 +    (while (< i xref-marker-ring-length)
 +      (if (aref (cddr tags-location-ring) i)
 +	  (set-marker (aref (cddr tags-location-ring) i) nil))
 +      (setq i (1+ i))))
 +  (xref-clear-marker-stack)
 +  (setq tags-file-name nil
 +	tags-location-ring (make-ring xref-marker-ring-length)
 +	tags-table-list nil
 +	tags-table-computed-list nil
 +	tags-table-computed-list-for nil
 +	tags-table-list-pointer nil
 +	tags-table-list-started-at nil
 +	tags-table-set-list nil))
 +
 +(defun file-of-tag (&optional relative)
 +  "Return the file name of the file whose tags point is within.
 +Assumes the tags table is the current buffer.
 +If RELATIVE is non-nil, file name returned is relative to tags
 +table file's directory. If RELATIVE is nil, file name returned
 +is complete."
 +  (funcall file-of-tag-function relative))
 +
 +;;;###autoload
 +(defun tags-table-files ()
 +  "Return a list of files in the current tags table.
 +Assumes the tags table is the current buffer.  The file names are returned
 +as they appeared in the `etags' command that created the table, usually
 +without directory names."
 +  (or tags-table-files
 +      (setq tags-table-files
 +	    (funcall tags-table-files-function))))
 +
 +(defun tags-included-tables ()
 +  "Return a list of tags tables included by the current table.
 +Assumes the tags table is the current buffer."
 +  (or tags-included-tables
 +      (setq tags-included-tables (funcall tags-included-tables-function))))
 +
 +(defun tags-completion-table ()
 +  "Build `tags-completion-table' on demand.
 +The tags included in the completion table are those in the current
 +tags table and its (recursively) included tags tables."
 +  (or tags-completion-table
 +      ;; No cached value for this buffer.
 +      (condition-case ()
 +	  (let (current-table combined-table)
 +	    (message "Making tags completion table for %s..." buffer-file-name)
 +	    (save-excursion
 +	      ;; Iterate over the current list of tags tables.
 +	      (while (visit-tags-table-buffer (and combined-table t))
 +		;; Find possible completions in this table.
 +		(setq current-table (funcall tags-completion-table-function))
 +		;; Merge this buffer's completions into the combined table.
 +		(if combined-table
 +		    (mapatoms
 +		     (lambda (sym) (intern (symbol-name sym) combined-table))
 +		     current-table)
 +		  (setq combined-table current-table))))
 +	    (message "Making tags completion table for %s...done"
 +		     buffer-file-name)
 +	    ;; Cache the result in a buffer-local variable.
 +	    (setq tags-completion-table combined-table))
 +	(quit (message "Tags completion table construction aborted.")
 +	      (setq tags-completion-table nil)))))
 +
 +;;;###autoload
 +(defun tags-lazy-completion-table ()
 +  (let ((buf (current-buffer)))
 +    (lambda (string pred action)
 +      (with-current-buffer buf
 +        (save-excursion
 +          ;; If we need to ask for the tag table, allow that.
 +          (let ((enable-recursive-minibuffers t))
 +            (visit-tags-table-buffer))
 +          (complete-with-action action (tags-completion-table) string pred))))))
 +
 +;;;###autoload (defun tags-completion-at-point-function ()
 +;;;###autoload   (if (or tags-table-list tags-file-name)
 +;;;###autoload       (progn
 +;;;###autoload         (load "etags")
 +;;;###autoload         (tags-completion-at-point-function))))
 +
 +(defun tags-completion-at-point-function ()
 +  "Using tags, return a completion table for the text around point.
 +If no tags table is loaded, do nothing and return nil."
 +  (when (or tags-table-list tags-file-name)
 +    (let ((completion-ignore-case (if (memq tags-case-fold-search '(t nil))
 +				      tags-case-fold-search
 +				    case-fold-search))
 +	  (pattern (funcall (or find-tag-default-function
 +				(get major-mode 'find-tag-default-function)
 +				'find-tag-default)))
 +	  beg)
 +      (when pattern
 +	(save-excursion
 +          (forward-char (1- (length pattern)))
 +          (search-backward pattern)
 +          (setq beg (point))
 +          (forward-char (length pattern))
 +          (list beg (point) (tags-lazy-completion-table) :exclusive 'no))))))
 +
 +(defun find-tag-tag (string)
 +  "Read a tag name, with defaulting and completion."
 +  (let* ((completion-ignore-case (if (memq tags-case-fold-search '(t nil))
 +				     tags-case-fold-search
 +				   case-fold-search))
 +	 (default (funcall (or find-tag-default-function
 +			       (get major-mode 'find-tag-default-function)
 +			       'find-tag-default)))
 +	 (spec (completing-read (if default
 +				    (format "%s (default %s): "
 +					    (substring string 0 (string-match "[ :]+\\'" string))
 +					    default)
 +				  string)
 +				(tags-lazy-completion-table)
 +				nil nil nil nil default)))
 +    (if (equal spec "")
 +	(or default (user-error "There is no default tag"))
 +      spec)))
 +
 +(defvar last-tag nil
 +  "Last tag found by \\[find-tag].")
 +
 +(defun find-tag-interactive (prompt &optional no-default)
 +  "Get interactive arguments for tag functions.
 +The functions using this are `find-tag-noselect',
 +`find-tag-other-window', and `find-tag-regexp'."
 +  (if (and current-prefix-arg last-tag)
 +      (list nil (if (< (prefix-numeric-value current-prefix-arg) 0)
 +		    '-
 +		  t))
 +    (list (if no-default
 +	      (read-string prompt)
 +	    (find-tag-tag prompt)))))
 +
 +(defvar find-tag-history nil) ; Doc string?
 +
 +;; Dynamic bondage:
 +(defvar etags-case-fold-search)
 +(defvar etags-syntax-table)
 +(defvar local-find-tag-hook)
 +
 +;;;###autoload
 +(defun find-tag-noselect (tagname &optional next-p regexp-p)
 +  "Find tag (in current tags table) whose name contains TAGNAME.
 +Returns the buffer containing the tag's definition and moves its point there,
 +but does not select the buffer.
 +The default for TAGNAME is the expression in the buffer near point.
 +
 +If second arg NEXT-P is t (interactively, with prefix arg), search for
 +another tag that matches the last tagname or regexp used.  When there are
 +multiple matches for a tag, more exact matches are found first.  If NEXT-P
 +is the atom `-' (interactively, with prefix arg that is a negative number
 +or just \\[negative-argument]), pop back to the previous tag gone to.
 +
 +If third arg REGEXP-P is non-nil, treat TAGNAME as a regexp.
 +
 +A marker representing the point when this command is invoked is pushed
 +onto a ring and may be popped back to with \\[pop-tag-mark].
 +Contrast this with the ring of marks gone to by the command.
 +
 +See documentation of variable `tags-file-name'."
 +  (interactive (find-tag-interactive "Find tag: "))
 +
 +  (setq find-tag-history (cons tagname find-tag-history))
 +  ;; Save the current buffer's value of `find-tag-hook' before
 +  ;; selecting the tags table buffer.  For the same reason, save value
 +  ;; of `tags-file-name' in case it has a buffer-local value.
 +  (let ((local-find-tag-hook find-tag-hook))
 +    (if (eq '- next-p)
 +	;; Pop back to a previous location.
 +	(if (ring-empty-p tags-location-ring)
 +	    (user-error "No previous tag locations")
 +	  (let ((marker (ring-remove tags-location-ring 0)))
 +	    (prog1
 +		;; Move to the saved location.
 +		(set-buffer (or (marker-buffer marker)
 +                                (error "The marked buffer has been deleted")))
 +	      (goto-char (marker-position marker))
 +	      ;; Kill that marker so it doesn't slow down editing.
 +	      (set-marker marker nil nil)
 +	      ;; Run the user's hook.  Do we really want to do this for pop?
 +	      (run-hooks 'local-find-tag-hook))))
 +      ;; Record whence we came.
 +      (xref-push-marker-stack)
 +      (if (and next-p last-tag)
 +	  ;; Find the same table we last used.
 +	  (visit-tags-table-buffer 'same)
 +	;; Pick a table to use.
 +	(visit-tags-table-buffer)
 +	;; Record TAGNAME for a future call with NEXT-P non-nil.
 +	(setq last-tag tagname))
 +      ;; Record the location so we can pop back to it later.
 +      (let ((marker (make-marker)))
 +	(with-current-buffer
 +            ;; find-tag-in-order does the real work.
 +            (find-tag-in-order
 +             (if (and next-p last-tag) last-tag tagname)
 +             (if regexp-p
 +                 find-tag-regexp-search-function
 +               find-tag-search-function)
 +             (if regexp-p
 +                 find-tag-regexp-tag-order
 +               find-tag-tag-order)
 +             (if regexp-p
 +                 find-tag-regexp-next-line-after-failure-p
 +               find-tag-next-line-after-failure-p)
 +             (if regexp-p "matching" "containing")
 +             (or (not next-p) (not last-tag)))
 +	  (set-marker marker (point))
 +	  (run-hooks 'local-find-tag-hook)
 +	  (ring-insert tags-location-ring marker)
 +	  (current-buffer))))))
 +
 +;;;###autoload
 +(defun find-tag (tagname &optional next-p regexp-p)
 +  "Find tag (in current tags table) whose name contains TAGNAME.
 +Select the buffer containing the tag's definition, and move point there.
 +The default for TAGNAME is the expression in the buffer around or before point.
 +
 +If second arg NEXT-P is t (interactively, with prefix arg), search for
 +another tag that matches the last tagname or regexp used.  When there are
 +multiple matches for a tag, more exact matches are found first.  If NEXT-P
 +is the atom `-' (interactively, with prefix arg that is a negative number
 +or just \\[negative-argument]), pop back to the previous tag gone to.
 +
 +If third arg REGEXP-P is non-nil, treat TAGNAME as a regexp.
 +
 +A marker representing the point when this command is invoked is pushed
 +onto a ring and may be popped back to with \\[pop-tag-mark].
 +Contrast this with the ring of marks gone to by the command.
 +
 +See documentation of variable `tags-file-name'."
 +  (interactive (find-tag-interactive "Find tag: "))
 +  (let* ((buf (find-tag-noselect tagname next-p regexp-p))
 +	 (pos (with-current-buffer buf (point))))
 +    (condition-case nil
 +	(switch-to-buffer buf)
 +      (error (pop-to-buffer buf)))
 +    (goto-char pos)))
 +
 +;;;###autoload
 +(defun find-tag-other-window (tagname &optional next-p regexp-p)
 +  "Find tag (in current tags table) whose name contains TAGNAME.
 +Select the buffer containing the tag's definition in another window, and
 +move point there.  The default for TAGNAME is the expression in the buffer
 +around or before point.
 +
 +If second arg NEXT-P is t (interactively, with prefix arg), search for
 +another tag that matches the last tagname or regexp used.  When there are
 +multiple matches for a tag, more exact matches are found first.  If NEXT-P
 +is negative (interactively, with prefix arg that is a negative number or
 +just \\[negative-argument]), pop back to the previous tag gone to.
 +
 +If third arg REGEXP-P is non-nil, treat TAGNAME as a regexp.
 +
 +A marker representing the point when this command is invoked is pushed
 +onto a ring and may be popped back to with \\[pop-tag-mark].
 +Contrast this with the ring of marks gone to by the command.
 +
 +See documentation of variable `tags-file-name'."
 +  (declare (obsolete xref-find-definitions-other-window "25.1"))
 +  (interactive (find-tag-interactive "Find tag other window: "))
 +
 +  ;; This hair is to deal with the case where the tag is found in the
 +  ;; selected window's buffer; without the hair, point is moved in both
 +  ;; windows.  To prevent this, we save the selected window's point before
 +  ;; doing find-tag-noselect, and restore it after.
 +  (let* ((window-point (window-point))
 +	 (tagbuf (find-tag-noselect tagname next-p regexp-p))
 +	 (tagpoint (progn (set-buffer tagbuf) (point))))
 +    (set-window-point (prog1
 +			  (selected-window)
 +			(switch-to-buffer-other-window tagbuf)
 +			;; We have to set this new window's point; it
 +			;; might already have been displaying a
 +			;; different portion of tagbuf, in which case
 +			;; switch-to-buffer-other-window doesn't set
 +			;; the window's point from the buffer.
 +			(set-window-point (selected-window) tagpoint))
 +		      window-point)))
 +
 +;;;###autoload
 +(defun find-tag-other-frame (tagname &optional next-p)
 +  "Find tag (in current tags table) whose name contains TAGNAME.
 +Select the buffer containing the tag's definition in another frame, and
 +move point there.  The default for TAGNAME is the expression in the buffer
 +around or before point.
 +
 +If second arg NEXT-P is t (interactively, with prefix arg), search for
 +another tag that matches the last tagname or regexp used.  When there are
 +multiple matches for a tag, more exact matches are found first.  If NEXT-P
 +is negative (interactively, with prefix arg that is a negative number or
 +just \\[negative-argument]), pop back to the previous tag gone to.
 +
 +If third arg REGEXP-P is non-nil, treat TAGNAME as a regexp.
 +
 +A marker representing the point when this command is invoked is pushed
 +onto a ring and may be popped back to with \\[pop-tag-mark].
 +Contrast this with the ring of marks gone to by the command.
 +
 +See documentation of variable `tags-file-name'."
 +  (declare (obsolete xref-find-definitions-other-frame "25.1"))
 +  (interactive (find-tag-interactive "Find tag other frame: "))
 +  (let ((pop-up-frames t))
 +    (find-tag-other-window tagname next-p)))
 +
 +;;;###autoload
 +(defun find-tag-regexp (regexp &optional next-p other-window)
 +  "Find tag (in current tags table) whose name matches REGEXP.
 +Select the buffer containing the tag's definition and move point there.
 +
 +If second arg NEXT-P is t (interactively, with prefix arg), search for
 +another tag that matches the last tagname or regexp used.  When there are
 +multiple matches for a tag, more exact matches are found first.  If NEXT-P
 +is negative (interactively, with prefix arg that is a negative number or
 +just \\[negative-argument]), pop back to the previous tag gone to.
 +
 +If third arg OTHER-WINDOW is non-nil, select the buffer in another window.
 +
 +A marker representing the point when this command is invoked is pushed
 +onto a ring and may be popped back to with \\[pop-tag-mark].
 +Contrast this with the ring of marks gone to by the command.
 +
 +See documentation of variable `tags-file-name'."
 +  (declare (obsolete xref-find-apropos "25.1"))
 +  (interactive (find-tag-interactive "Find tag regexp: " t))
 +  ;; We go through find-tag-other-window to do all the display hair there.
 +  (funcall (if other-window 'find-tag-other-window 'find-tag)
 +	   regexp next-p t))
 +
 +;;;###autoload
 +(defalias 'pop-tag-mark 'xref-pop-marker-stack)
 +
 +
 +(defvar tag-lines-already-matched nil
 +  "Matches remembered between calls.") ; Doc string: calls to what?
 +
 +(defun find-tag-in-order (pattern
 +			  search-forward-func
 +			  order
 +			  next-line-after-failure-p
 +			  matching
 +			  first-search)
 +  "Internal tag-finding function.
 +PATTERN is a string to pass to arg SEARCH-FORWARD-FUNC, and to any
 +member of the function list ORDER.  If ORDER is nil, use saved state
 +to continue a previous search.
 +
 +Arg NEXT-LINE-AFTER-FAILURE-P is non-nil if after a failed match,
 +point should be moved to the next line.
 +
 +Arg MATCHING is a string, an English `-ing' word, to be used in an
 +error message."
 +;; Algorithm is as follows:
 +;; For each qualifier-func in ORDER, go to beginning of tags file, and
 +;; perform inner loop: for each naive match for PATTERN found using
 +;; SEARCH-FORWARD-FUNC, qualify the naive match using qualifier-func.  If
 +;; it qualifies, go to the specified line in the specified source file
 +;; and return.  Qualified matches are remembered to avoid repetition.
 +;; State is saved so that the loop can be continued.
 +  (let (file				;name of file containing tag
 +	tag-info			;where to find the tag in FILE
 +	(first-table t)
 +	(tag-order order)
 +	(match-marker (make-marker))
 +	goto-func
 +	(case-fold-search (if (memq tags-case-fold-search '(nil t))
 +			      tags-case-fold-search
 +			    case-fold-search))
 +	)
 +    (save-excursion
 +
 +      (if first-search
 +	  ;; This is the start of a search for a fresh tag.
 +	  ;; Clear the list of tags matched by the previous search.
 +	  ;; find-tag-noselect has already put us in the first tags table
 +	  ;; buffer before we got called.
 +	  (setq tag-lines-already-matched nil)
 +	;; Continuing to search for the tag specified last time.
 +	;; tag-lines-already-matched lists locations matched in previous
 +	;; calls so we don't visit the same tag twice if it matches twice
 +	;; during two passes with different qualification predicates.
 +	;; Switch to the current tags table buffer.
 +	(visit-tags-table-buffer 'same))
 +
 +      ;; Get a qualified match.
 +      (catch 'qualified-match-found
 +
 +	;; Iterate over the list of tags tables.
 +	(while (or first-table
 +		   (visit-tags-table-buffer t))
 +
 +	  (and first-search first-table
 +	       ;; Start at beginning of tags file.
 +	       (goto-char (point-min)))
 +
 +	  (setq first-table nil)
 +
 +	  ;; Iterate over the list of ordering predicates.
 +	  (while order
 +	    (while (funcall search-forward-func pattern nil t)
 +	      ;; Naive match found.  Qualify the match.
 +	      (and (funcall (car order) pattern)
 +		   ;; Make sure it is not a previous qualified match.
 +		   (not (member (set-marker match-marker (point-at-bol))
 +				tag-lines-already-matched))
 +		   (throw 'qualified-match-found nil))
 +	      (if next-line-after-failure-p
 +		  (forward-line 1)))
 +	    ;; Try the next flavor of match.
 +	    (setq order (cdr order))
 +	    (goto-char (point-min)))
 +	  (setq order tag-order))
 +	;; We throw out on match, so only get here if there were no matches.
 +	;; Clear out the markers we use to avoid duplicate matches so they
 +	;; don't slow down editing and are immediately available for GC.
 +	(while tag-lines-already-matched
 +	  (set-marker (car tag-lines-already-matched) nil nil)
 +	  (setq tag-lines-already-matched (cdr tag-lines-already-matched)))
 +	(set-marker match-marker nil nil)
 +	(user-error "No %stags %s %s" (if first-search "" "more ")
 +                    matching pattern))
 +
 +      ;; Found a tag; extract location info.
 +      (beginning-of-line)
 +      (setq tag-lines-already-matched (cons match-marker
 +					    tag-lines-already-matched))
 +      ;; Expand the filename, using the tags table buffer's default-directory.
 +      ;; We should be able to search for file-name backwards in file-of-tag:
 +      ;; the beginning-of-line is ok except when positioned on a "file-name" tag.
 +      (setq file (expand-file-name
 +		  (if (memq (car order) '(tag-exact-file-name-match-p
 +					  tag-file-name-match-p
 +					  tag-partial-file-name-match-p))
 +                      (save-excursion (forward-line 1)
 +                                      (file-of-tag))
 +                    (file-of-tag)))
 +	    tag-info (funcall snarf-tag-function))
 +
 +      ;; Get the local value in the tags table buffer before switching buffers.
 +      (setq goto-func goto-tag-location-function)
 +      (tag-find-file-of-tag-noselect file)
 +      (widen)
 +      (push-mark)
 +      (funcall goto-func tag-info)
 +
 +      ;; Return the buffer where the tag was found.
 +      (current-buffer))))
 +
 +(defun tag-find-file-of-tag-noselect (file)
 +  "Find the right line in the specified FILE."
 +  ;; If interested in compressed-files, search files with extensions.
 +  ;; Otherwise, search only the real file.
 +  (let* ((buffer-search-extensions (if auto-compression-mode
 +				       tags-compression-info-list
 +				     '("")))
 +	 the-buffer
 +	 (file-search-extensions buffer-search-extensions))
 +    ;; search a buffer visiting the file with each possible extension
 +    ;; Note: there is a small inefficiency in find-buffer-visiting :
 +    ;;   truename is computed even if not needed. Not too sure about this
 +    ;;   but I suspect truename computation accesses the disk.
 +    ;;   It is maybe a good idea to optimize this find-buffer-visiting.
 +    ;; An alternative would be to use only get-file-buffer
 +    ;; but this looks less "sure" to find the buffer for the file.
 +    (while (and (not the-buffer) buffer-search-extensions)
 +      (setq the-buffer (find-buffer-visiting (concat file (car buffer-search-extensions))))
 +      (setq buffer-search-extensions (cdr buffer-search-extensions)))
 +    ;; if found a buffer but file modified, ensure we re-read !
 +    (if (and the-buffer (not (verify-visited-file-modtime the-buffer)))
 +	(find-file-noselect (buffer-file-name the-buffer)))
 +    ;; if no buffer found, search for files with possible extensions on disk
 +    (while (and (not the-buffer) file-search-extensions)
 +      (if (not (file-exists-p (concat file (car file-search-extensions))))
 +	  (setq file-search-extensions (cdr file-search-extensions))
 +	(setq the-buffer (find-file-noselect (concat file (car file-search-extensions))))))
 +    (if (not the-buffer)
 +	(if auto-compression-mode
 +	    (error "File %s (with or without extensions %s) not found" file tags-compression-info-list)
 +	  (error "File %s not found" file))
 +      (set-buffer the-buffer))))
 +
 +(defun tag-find-file-of-tag (file) ; Doc string?
 +  (let ((buf (tag-find-file-of-tag-noselect file)))
 +    (condition-case nil
 +	(switch-to-buffer buf)
 +      (error (pop-to-buffer buf)))))
 +
 +;; `etags' TAGS file format support.
 +
 +(defun etags-recognize-tags-table ()
 +  "If `etags-verify-tags-table', make buffer-local format variables.
 +If current buffer is a valid etags TAGS file, then give it
 +buffer-local values of tags table format variables."
 +  (and (etags-verify-tags-table)
 +       ;; It is annoying to flash messages on the screen briefly,
 +       ;; and this message is not useful.  -- rms
 +       ;; (message "%s is an `etags' TAGS file" buffer-file-name)
 +       (mapc (lambda (elt) (set (make-local-variable (car elt)) (cdr elt)))
 +	     '((file-of-tag-function . etags-file-of-tag)
 +	       (tags-table-files-function . etags-tags-table-files)
 +	       (tags-completion-table-function . etags-tags-completion-table)
 +	       (snarf-tag-function . etags-snarf-tag)
 +	       (goto-tag-location-function . etags-goto-tag-location)
 +	       (find-tag-regexp-search-function . re-search-forward)
 +	       (find-tag-regexp-tag-order . (tag-re-match-p))
 +	       (find-tag-regexp-next-line-after-failure-p . t)
 +	       (find-tag-search-function . search-forward)
 +	       (find-tag-tag-order . (tag-exact-file-name-match-p
 +                                      tag-file-name-match-p
 +				      tag-exact-match-p
 +				      tag-implicit-name-match-p
 +				      tag-symbol-match-p
 +				      tag-word-match-p
 +				      tag-partial-file-name-match-p
 +				      tag-any-match-p))
 +	       (find-tag-next-line-after-failure-p . nil)
 +	       (list-tags-function . etags-list-tags)
 +	       (tags-apropos-function . etags-tags-apropos)
 +	       (tags-included-tables-function . etags-tags-included-tables)
 +	       (verify-tags-table-function . etags-verify-tags-table)
 +	       ))))
 +
 +(defun etags-verify-tags-table ()
 +  "Return non-nil if the current buffer is a valid etags TAGS file."
 +  ;; Use eq instead of = in case char-after returns nil.
 +  (eq (char-after (point-min)) ?\f))
 +
 +(defun etags-file-of-tag (&optional relative) ; Doc string?
 +  (save-excursion
 +    (re-search-backward "\f\n\\([^\n]+\\),[0-9]*\n")
 +    (let ((str (convert-standard-filename
 +                (buffer-substring (match-beginning 1) (match-end 1)))))
 +      (if relative
 +	  str
 +	(expand-file-name str (file-truename default-directory))))))
 +
 +
 +(defun etags-tags-completion-table () ; Doc string?
 +  (let ((table (make-vector 511 0))
 +	(progress-reporter
 +	 (make-progress-reporter
 +	  (format "Making tags completion table for %s..." buffer-file-name)
 +	  (point-min) (point-max))))
 +    (save-excursion
 +      (goto-char (point-min))
 +      ;; This monster regexp matches an etags tag line.
 +      ;;   \1 is the string to match;
 +      ;;   \2 is not interesting;
 +      ;;   \3 is the guessed tag name; XXX guess should be better eg DEFUN
 +      ;;   \4 is not interesting;
 +      ;;   \5 is the explicitly-specified tag name.
 +      ;;   \6 is the line to start searching at;
 +      ;;   \7 is the char to start searching at.
 +      (while (re-search-forward
 +	      "^\\(\\([^\177]+[^-a-zA-Z0-9_+*$:\177]+\\)?\
 +\\([-a-zA-Z0-9_+*$?:]+\\)[^-a-zA-Z0-9_+*$?:\177]*\\)\177\
 +\\(\\([^\n\001]+\\)\001\\)?\\([0-9]+\\)?,\\([0-9]+\\)?\n"
 +	      nil t)
 +	(intern	(prog1 (if (match-beginning 5)
 +			   ;; There is an explicit tag name.
 +			   (buffer-substring (match-beginning 5) (match-end 5))
 +			 ;; No explicit tag name.  Best guess.
 +			 (buffer-substring (match-beginning 3) (match-end 3)))
 +		  (progress-reporter-update progress-reporter (point)))
 +		table)))
 +    table))
 +
 +(defun etags-snarf-tag (&optional use-explicit) ; Doc string?
 +  (let (tag-text line startpos explicit-start)
 +    (if (save-excursion
 +	  (forward-line -1)
 +	  (looking-at "\f\n"))
 +	;; The match was for a source file name, not any tag within a file.
 +	;; Give text of t, meaning to go exactly to the location we specify,
 +	;; the beginning of the file.
 +	(setq tag-text t
 +	      line nil
 +	      startpos (point-min))
 +
 +      ;; Find the end of the tag and record the whole tag text.
 +      (search-forward "\177")
 +      (setq tag-text (buffer-substring (1- (point)) (point-at-bol)))
 +      ;; If use-explicit is non nil and explicit tag is present, use it as part of
 +      ;; return value. Else just skip it.
 +      (setq explicit-start (point))
 +      (when (and (search-forward "\001" (point-at-bol 2) t)
 +		 use-explicit)
 +	(setq tag-text (buffer-substring explicit-start (1- (point)))))
 +
 +
 +      (if (looking-at "[0-9]")
 +	  (setq line (string-to-number (buffer-substring
 +                                        (point)
 +                                        (progn (skip-chars-forward "0-9")
 +                                               (point))))))
 +      (search-forward ",")
 +      (if (looking-at "[0-9]")
 +	  (setq startpos (string-to-number (buffer-substring
 +                                            (point)
 +                                            (progn (skip-chars-forward "0-9")
 +                                                   (point)))))))
 +    ;; Leave point on the next line of the tags file.
 +    (forward-line 1)
 +    (cons tag-text (cons line startpos))))
 +
 +(defun etags-goto-tag-location (tag-info)
 +  "Go to location of tag specified by TAG-INFO.
 +TAG-INFO is a cons (TEXT LINE . POSITION).
 +TEXT is the initial part of a line containing the tag.
 +LINE is the line number.
 +POSITION is the (one-based) char position of TEXT within the file.
 +
 +If TEXT is t, it means the tag refers to exactly LINE or POSITION,
 +whichever is present, LINE having preference, no searching.
 +Either LINE or POSITION can be nil.  POSITION is used if present.
 +
 +If the tag isn't exactly at the given position, then look near that
 +position using a search window that expands progressively until it
 +hits the start of file."
 +  (let ((startpos (cdr (cdr tag-info)))
 +	(line (car (cdr tag-info)))
 +	offset found pat)
 +    (if (eq (car tag-info) t)
 +	;; Direct file tag.
 +	(cond (line (progn (goto-char (point-min))
 +			   (forward-line (1- line))))
 +	      (startpos (goto-char startpos))
 +	      (t (error "etags.el BUG: bogus direct file tag")))
 +      ;; This constant is 1/2 the initial search window.
 +      ;; There is no sense in making it too small,
 +      ;; since just going around the loop once probably
 +      ;; costs about as much as searching 2000 chars.
 +      (setq offset 1000
 +	    found nil
 +	    pat (concat (if (eq selective-display t)
 +			    "\\(^\\|\^m\\)" "^")
 +			(regexp-quote (car tag-info))))
 +      ;; The character position in the tags table is 0-origin.
 +      ;; Convert it to a 1-origin Emacs character position.
 +      (if startpos (setq startpos (1+ startpos)))
 +      ;; If no char pos was given, try the given line number.
 +      (or startpos
 +	  (if line
 +	      (setq startpos (progn (goto-char (point-min))
 +				    (forward-line (1- line))
 +				    (point)))))
 +      (or startpos
 +	  (setq startpos (point-min)))
 +      ;; First see if the tag is right at the specified location.
 +      (goto-char startpos)
 +      (setq found (looking-at pat))
 +      (while (and (not found)
 +		  (progn
 +		    (goto-char (- startpos offset))
 +		    (not (bobp))))
 +	(setq found
 +	      (re-search-forward pat (+ startpos offset) t)
 +	      offset (* 3 offset)))	; expand search window
 +      (or found
 +	  (re-search-forward pat nil t)
 +	  (user-error "Rerun etags: `%s' not found in %s"
 +                      pat buffer-file-name)))
 +    ;; Position point at the right place
 +    ;; if the search string matched an extra Ctrl-m at the beginning.
 +    (and (eq selective-display t)
 +	 (looking-at "\^m")
 +	 (forward-char 1))
 +    (beginning-of-line)))
 +
 +(defun etags-list-tags (file) ; Doc string?
 +  (goto-char (point-min))
 +  (when (re-search-forward (concat "\f\n" "\\(" file "\\)" ",") nil t)
 +    (let ((path (save-excursion (forward-line 1) (file-of-tag)))
 +	  ;; Get the local value in the tags table
 +	  ;; buffer before switching buffers.
 +	  (goto-func goto-tag-location-function)
 +	  tag tag-info pt)
 +    (forward-line 1)
 +    (while (not (or (eobp) (looking-at "\f")))
 +      ;; We used to use explicit tags when available, but the current goto-func
 +      ;; can only handle implicit tags.
 +      (setq tag-info (save-excursion (funcall snarf-tag-function nil))
 +	    tag (car tag-info)
 +	    pt (with-current-buffer standard-output (point)))
 +      (princ tag)
 +      (when (= (aref tag 0) ?\() (princ " ...)"))
 +      (with-current-buffer standard-output
 +	(make-text-button pt (point)
 +			  'tag-info tag-info
 +			  'file-path path
 +			  'goto-func goto-func
 +			  'action (lambda (button)
 +				    (let ((tag-info (button-get button 'tag-info))
 +					  (goto-func (button-get button 'goto-func)))
 +				      (tag-find-file-of-tag (button-get button 'file-path))
 +				      (widen)
 +				      (funcall goto-func tag-info)))
 +			  'follow-link t
 +			  'face tags-tag-face
 +			  'type 'button))
 +      (terpri)
 +      (forward-line 1))
 +    t)))
 +
 +(defmacro tags-with-face (face &rest body)
 +  "Execute BODY, give output to `standard-output' face FACE."
 +  (let ((pp (make-symbol "start")))
 +    `(let ((,pp (with-current-buffer standard-output (point))))
 +       ,@body
 +       (put-text-property ,pp (with-current-buffer standard-output (point))
 +			  'face ,face standard-output))))
 +
 +(defun etags-tags-apropos-additional (regexp)
 +  "Display tags matching REGEXP from `tags-apropos-additional-actions'."
 +  (with-current-buffer standard-output
 +    (dolist (oba tags-apropos-additional-actions)
 +      (princ "\n\n")
 +      (tags-with-face 'highlight (princ (car oba)))
 +      (princ":\n\n")
 +      (let* ((beg (point))
 +	     (symbs (car (cddr oba)))
 +             (ins-symb (lambda (sy)
 +                         (let ((sn (symbol-name sy)))
 +                           (when (string-match regexp sn)
 +                             (make-text-button (point)
 +					  (progn (princ sy) (point))
 +					  'action-internal(cadr oba)
 +					  'action (lambda (button) (funcall
 +								    (button-get button 'action-internal)
 +								    (button-get button 'item)))
 +					  'item sn
 +					  'face tags-tag-face
 +					  'follow-link t
 +					  'type 'button)
 +                             (terpri))))))
 +        (when (symbolp symbs)
 +          (if (boundp symbs)
 +	      (setq symbs (symbol-value symbs))
 +	    (insert "symbol `" (symbol-name symbs) "' has no value\n")
 +	    (setq symbs nil)))
 +        (if (vectorp symbs)
 +	    (mapatoms ins-symb symbs)
 +	  (dolist (sy symbs)
 +	    (funcall ins-symb (car sy))))
 +        (sort-lines nil beg (point))))))
 +
 +(defun etags-tags-apropos (string) ; Doc string?
 +  (when tags-apropos-verbose
 +    (princ "Tags in file `")
 +    (tags-with-face 'highlight (princ buffer-file-name))
 +    (princ "':\n\n"))
 +  (goto-char (point-min))
 +  (let ((progress-reporter (make-progress-reporter
 +			    (format "Making tags apropos buffer for `%s'..."
 +				    string)
 +			    (point-min) (point-max))))
 +    (while (re-search-forward string nil t)
 +      (progress-reporter-update progress-reporter (point))
 +      (beginning-of-line)
 +
 +      (let* ( ;; Get the local value in the tags table
 +	     ;; buffer before switching buffers.
 +	     (goto-func goto-tag-location-function)
 +	     (tag-info (save-excursion (funcall snarf-tag-function)))
 +	     (tag (if (eq t (car tag-info)) nil (car tag-info)))
 +	     (file-path (save-excursion (if tag (file-of-tag)
 +					  (save-excursion (forward-line 1)
 +							  (file-of-tag)))))
 +	     (file-label (if tag (file-of-tag t)
 +			   (save-excursion (forward-line 1)
 +					   (file-of-tag t))))
 +	     (pt (with-current-buffer standard-output (point))))
 +	(if tag
 +	    (progn
 +	      (princ (format "[%s]: " file-label))
 +	      (princ tag)
 +	      (when (= (aref tag 0) ?\() (princ " ...)"))
 +	      (with-current-buffer standard-output
 +		(make-text-button pt (point)
 +				  'tag-info tag-info
 +				  'file-path file-path
 +				  'goto-func goto-func
 +				  'action (lambda (button)
 +					    (let ((tag-info (button-get button 'tag-info))
 +						  (goto-func (button-get button 'goto-func)))
 +					      (tag-find-file-of-tag (button-get button 'file-path))
 +					      (widen)
 +					      (funcall goto-func tag-info)))
 +				  'follow-link t
 +				  'face tags-tag-face
 +				  'type 'button)))
 +	  (princ (format "- %s" file-label))
 +	  (with-current-buffer standard-output
 +	    (make-text-button pt (point)
 +			      'file-path file-path
 +			      'action (lambda (button)
 +					(tag-find-file-of-tag (button-get button 'file-path))
 +					;; Get the local value in the tags table
 +					;; buffer before switching buffers.
 +					(goto-char (point-min)))
 +			      'follow-link t
 +			      'face tags-tag-face
 +			      'type 'button))))
 +      (terpri)
 +      (forward-line 1))
 +    (message nil))
 +  (when tags-apropos-verbose (princ "\n")))
 +
 +(defun etags-tags-table-files () ; Doc string?
 +  (let ((files nil)
 +	beg)
 +    (goto-char (point-min))
 +    (while (search-forward "\f\n" nil t)
 +      (setq beg (point))
 +      (end-of-line)
 +      (skip-chars-backward "^," beg)
 +      (or (looking-at "include$")
 +	  (push (convert-standard-filename
 +                 (buffer-substring beg (1- (point))))
 +                files)))
 +    (nreverse files)))
 +
 +;; FIXME?  Should this save-excursion?
 +(defun etags-tags-included-tables () ; Doc string?
 +  (let ((files nil)
 +	beg)
 +    (goto-char (point-min))
 +    (while (search-forward "\f\n" nil t)
 +      (setq beg (point))
 +      (end-of-line)
 +      (skip-chars-backward "^," beg)
 +      (when (looking-at "include$")
 +        ;; Expand in the default-directory of the tags table buffer.
 +        (push (expand-file-name (convert-standard-filename
 +                                 (buffer-substring beg (1- (point)))))
 +              files)))
 +    (nreverse files)))
 +
 +;; Empty tags file support.
 +
 +(defun tags-recognize-empty-tags-table ()
 +  "Return non-nil if current buffer is empty.
 +If empty, make buffer-local values of the tags table format variables
 +that do nothing."
 +  (and (zerop (buffer-size))
 +       (mapc (lambda (sym) (set (make-local-variable sym) 'ignore))
 +	     '(tags-table-files-function
 +	       tags-completion-table-function
 +	       find-tag-regexp-search-function
 +	       find-tag-search-function
 +	       tags-apropos-function
 +	       tags-included-tables-function))
 +       (set (make-local-variable 'verify-tags-table-function)
 +            (lambda () (zerop (buffer-size))))))
 +
 +;; Match qualifier functions for tagnames.
 +;; These functions assume the etags file format defined in etc/ETAGS.EBNF.
 +
 +;; This might be a neat idea, but it's too hairy at the moment.
 +;;(defmacro tags-with-syntax (&rest body)
 +;;   `(with-syntax-table
 +;;        (with-current-buffer (find-file-noselect (file-of-tag))
 +;;          (syntax-table))
 +;;      ,@body))
 +;;(put 'tags-with-syntax 'edebug-form-spec '(&rest form))
 +
 +;; exact file name match, i.e. searched tag must match complete file
 +;; name including directories parts if there are some.
 +(defun tag-exact-file-name-match-p (tag)
 +  "Return non-nil if TAG matches complete file name.
 +Any directory part of the file name is also matched."
 +  (and (looking-at ",[0-9\n]")
 +       (save-excursion (backward-char (+ 2 (length tag)))
 +		       (looking-at "\f\n"))))
 +
 +;; file name match as above, but searched tag must match the file
 +;; name not including the directories if there are some.
 +(defun tag-file-name-match-p (tag)
 +  "Return non-nil if TAG matches file name, excluding directory part."
 +  (and (looking-at ",[0-9\n]")
 +       (save-excursion (backward-char (1+ (length tag)))
 +		       (looking-at "/"))))
 +
 +;; this / to detect we are after a directory separator is ok for unix,
 +;; is there a variable that contains the regexp for directory separator
 +;; on whatever operating system ?
 +;; Looks like ms-win will lose here :).
 +
 +;; t if point is at a tag line that matches TAG exactly.
 +;; point should be just after a string that matches TAG.
 +(defun tag-exact-match-p (tag)
 +  "Return non-nil if current tag line matches TAG exactly.
 +Point should be just after a string that matches TAG."
 +  ;; The match is really exact if there is an explicit tag name.
 +  (or (and (eq (char-after (point)) ?\001)
 +	   (eq (char-after (- (point) (length tag) 1)) ?\177))
 +      ;; We are not on the explicit tag name, but perhaps it follows.
 +      (looking-at (concat "[^\177\n]*\177" (regexp-quote tag) "\001"))))
 +
 +;; t if point is at a tag line that has an implicit name.
 +;; point should be just after a string that matches TAG.
 +(defun tag-implicit-name-match-p (tag)
 +  "Return non-nil if current tag line has an implicit name.
 +Point should be just after a string that matches TAG."
 +  ;; Look at the comment of the make_tag function in lib-src/etags.c for
 +  ;; a textual description of the four rules.
 +  (and (string-match "^[^ \t()=,;]+$" tag) ;rule #1
 +       (looking-at "[ \t()=,;]?\177")	;rules #2 and #4
 +       (save-excursion
 +	 (backward-char (1+ (length tag)))
 +	 (looking-at "[\n \t()=,;]"))))	;rule #3
 +
 +;; t if point is at a tag line that matches TAG as a symbol.
 +;; point should be just after a string that matches TAG.
 +(defun tag-symbol-match-p (tag)
 +  "Return non-nil if current tag line matches TAG as a symbol.
 +Point should be just after a string that matches TAG."
 +  (and (looking-at "\\Sw.*\177") (looking-at "\\S_.*\177")
 +       (save-excursion
 +	 (backward-char (1+ (length tag)))
 +	 (and (looking-at "\\Sw") (looking-at "\\S_")))))
 +
 +;; t if point is at a tag line that matches TAG as a word.
 +;; point should be just after a string that matches TAG.
 +(defun tag-word-match-p (tag)
 +  "Return non-nil if current tag line matches TAG as a word.
 +Point should be just after a string that matches TAG."
 +  (and (looking-at "\\b.*\177")
 +       (save-excursion (backward-char (length tag))
 +		       (looking-at "\\b"))))
 +
 +;; partial file name match, i.e. searched tag must match a substring
 +;; of the file name (potentially including a directory separator).
 +(defun tag-partial-file-name-match-p (_tag)
 +  "Return non-nil if current tag matches file name.
 +This is a substring match, and it can include directory separators.
 +Point should be just after a string that matches TAG."
 +  (and (looking-at ".*,[0-9\n]")
 +       (save-excursion (beginning-of-line)
 +                       (backward-char 2)
 +  		       (looking-at "\f\n"))))
 +
 +;; t if point is in a tag line with a tag containing TAG as a substring.
 +(defun tag-any-match-p (_tag)
 +  "Return non-nil if current tag line contains TAG as a substring."
 +  (looking-at ".*\177"))
 +
 +;; t if point is at a tag line that matches RE as a regexp.
 +(defun tag-re-match-p (re)
 +  "Return non-nil if current tag line matches regexp RE."
 +  (save-excursion
 +    (beginning-of-line)
 +    (let ((bol (point)))
 +      (and (search-forward "\177" (line-end-position) t)
 +	   (re-search-backward re bol t)))))
 +
 +(defcustom tags-loop-revert-buffers nil
 +  "Non-nil means tags-scanning loops should offer to reread changed files.
 +These loops normally read each file into Emacs, but when a file
 +is already visited, they use the existing buffer.
 +When this flag is non-nil, they offer to revert the existing buffer
 +in the case where the file has changed since you visited it."
 +  :type 'boolean
 +  :group 'etags)
 +
 +;;;###autoload
 +(defun next-file (&optional initialize novisit)
 +  "Select next file among files in current tags table.
 +
 +A first argument of t (prefix arg, if interactive) initializes to the
 +beginning of the list of files in the tags table.  If the argument is
 +neither nil nor t, it is evalled to initialize the list of files.
 +
 +Non-nil second argument NOVISIT means use a temporary buffer
 + to save time and avoid uninteresting warnings.
 +
 +Value is nil if the file was already visited;
 +if the file was newly read in, the value is the filename."
 +  ;; Make the interactive arg t if there was any prefix arg.
 +  (interactive (list (if current-prefix-arg t)))
 +  (cond ((not initialize)
 +	 ;; Not the first run.
 +	 )
 +	((eq initialize t)
 +	 ;; Initialize the list from the tags table.
 +	 (save-excursion
 +	   ;; Visit the tags table buffer to get its list of files.
 +	   (visit-tags-table-buffer)
 +	   ;; Copy the list so we can setcdr below, and expand the file
 +	   ;; names while we are at it, in this buffer's default directory.
 +	   (setq next-file-list (mapcar 'expand-file-name (tags-table-files)))
 +	   ;; Iterate over all the tags table files, collecting
 +	   ;; a complete list of referenced file names.
 +	   (while (visit-tags-table-buffer t)
 +	     ;; Find the tail of the working list and chain on the new
 +	     ;; sublist for this tags table.
 +	     (let ((tail next-file-list))
 +	       (while (cdr tail)
 +		 (setq tail (cdr tail)))
 +	       ;; Use a copy so the next loop iteration will not modify the
 +	       ;; list later returned by (tags-table-files).
 +	       (if tail
 +		   (setcdr tail (mapcar 'expand-file-name (tags-table-files)))
 +		 (setq next-file-list (mapcar 'expand-file-name
 +					      (tags-table-files))))))))
 +	(t
 +	 ;; Initialize the list by evalling the argument.
 +	 (setq next-file-list (eval initialize))))
 +  (unless next-file-list
 +    (and novisit
 +	 (get-buffer " *next-file*")
 +	 (kill-buffer " *next-file*"))
 +    (user-error "All files processed"))
 +  (let* ((next (car next-file-list))
 +	 (buffer (get-file-buffer next))
 +	 (new (not buffer)))
 +    ;; Advance the list before trying to find the file.
 +    ;; If we get an error finding the file, don't get stuck on it.
 +    (setq next-file-list (cdr next-file-list))
 +    ;; Optionally offer to revert buffers
 +    ;; if the files have changed on disk.
 +    (and buffer tags-loop-revert-buffers
 +	 (not (verify-visited-file-modtime buffer))
 +	 (y-or-n-p
 +	  (format
 +	   (if (buffer-modified-p buffer)
 +	       "File %s changed on disk.  Discard your edits? "
 +	     "File %s changed on disk.  Reread from disk? ")
 +	   next))
 +	 (with-current-buffer buffer
 +	   (revert-buffer t t)))
 +    (if (not (and new novisit))
 +	(find-file next novisit)
 +      ;; Like find-file, but avoids random warning messages.
 +      (switch-to-buffer (get-buffer-create " *next-file*"))
 +      (kill-all-local-variables)
 +      (erase-buffer)
 +      (setq new next)
 +      (insert-file-contents new nil))
 +    new))
 +
 +(defvar tags-loop-operate nil
 +  "Form for `tags-loop-continue' to eval to change one file.")
 +
 +(defvar tags-loop-scan
 +  '(user-error "%s"
 +	       (substitute-command-keys
 +	        "No \\[tags-search] or \\[tags-query-replace] in progress"))
 +  "Form for `tags-loop-continue' to eval to scan one file.
 +If it returns non-nil, this file needs processing by evalling
 +`tags-loop-operate'.  Otherwise, move on to the next file.")
 +
 +(defun tags-loop-eval (form)
 +  "Evaluate FORM and return its result.
 +Bind `case-fold-search' during the evaluation, depending on the value of
 +`tags-case-fold-search'."
 +  (let ((case-fold-search (if (memq tags-case-fold-search '(t nil))
 +			      tags-case-fold-search
 +			    case-fold-search)))
 +    (eval form)))
 +
 +
 +;;;###autoload
 +(defun tags-loop-continue (&optional first-time)
 +  "Continue last \\[tags-search] or \\[tags-query-replace] command.
 +Used noninteractively with non-nil argument to begin such a command (the
 +argument is passed to `next-file', which see).
 +
 +Two variables control the processing we do on each file: the value of
 +`tags-loop-scan' is a form to be executed on each file to see if it is
 +interesting (it returns non-nil if so) and `tags-loop-operate' is a form to
 +evaluate to operate on an interesting file.  If the latter evaluates to
 +nil, we exit; otherwise we scan the next file."
 +  (declare (obsolete "use `xref-find-definitions' interface instead." "25.1"))
 +  (interactive)
 +  (let (new
 +	;; Non-nil means we have finished one file
 +	;; and should not scan it again.
 +	file-finished
 +	original-point
 +	(messaged nil))
 +    (while
 +	(progn
 +	  ;; Scan files quickly for the first or next interesting one.
 +	  ;; This starts at point in the current buffer.
 +	  (while (or first-time file-finished
 +		     (save-restriction
 +		       (widen)
 +		       (not (tags-loop-eval tags-loop-scan))))
 +	    ;; If nothing was found in the previous file, and
 +	    ;; that file isn't in a temp buffer, restore point to
 +	    ;; where it was.
 +	    (when original-point
 +	      (goto-char original-point))
 +
 +	    (setq file-finished nil)
 +	    (setq new (next-file first-time t))
 +
 +	    ;; If NEW is non-nil, we got a temp buffer,
 +	    ;; and NEW is the file name.
 +	    (when (or messaged
 +		      (and (not first-time)
 +			   (> baud-rate search-slow-speed)
 +			   (setq messaged t)))
 +	      (message "Scanning file %s..." (or new buffer-file-name)))
 +
 +	    (setq first-time nil)
 +	    (setq original-point (if new nil (point)))
 +	    (goto-char (point-min)))
 +
 +	  ;; If we visited it in a temp buffer, visit it now for real.
 +	  (if new
 +	      (let ((pos (point)))
 +		(erase-buffer)
 +		(set-buffer (find-file-noselect new))
 +		(setq new nil)		;No longer in a temp buffer.
 +		(widen)
 +		(goto-char pos))
 +	    (push-mark original-point t))
 +
 +	  (switch-to-buffer (current-buffer))
 +
 +	  ;; Now operate on the file.
 +	  ;; If value is non-nil, continue to scan the next file.
 +	  (tags-loop-eval tags-loop-operate))
 +      (setq file-finished t))
 +    (and messaged
 +	 (null tags-loop-operate)
 +	 (message "Scanning file %s...found" buffer-file-name))))
 +
 +;;;###autoload
 +(defun tags-search (regexp &optional file-list-form)
 +  "Search through all files listed in tags table for match for REGEXP.
 +Stops when a match is found.
 +To continue searching for next match, use command \\[tags-loop-continue].
 +
 +If FILE-LIST-FORM is non-nil, it should be a form that, when
 +evaluated, will return a list of file names.  The search will be
 +restricted to these files.
 +
 +Also see the documentation of the `tags-file-name' variable."
 +  (interactive "sTags search (regexp): ")
 +  (if (and (equal regexp "")
 +	   (eq (car tags-loop-scan) 're-search-forward)
 +	   (null tags-loop-operate))
 +      ;; Continue last tags-search as if by M-,.
 +      (tags-loop-continue nil)
 +    (setq tags-loop-scan `(re-search-forward ',regexp nil t)
 +	  tags-loop-operate nil)
 +    (tags-loop-continue (or file-list-form t))))
 +
 +;;;###autoload
 +(defun tags-query-replace (from to &optional delimited file-list-form)
 +  "Do `query-replace-regexp' of FROM with TO on all files listed in tags table.
 +Third arg DELIMITED (prefix arg) means replace only word-delimited matches.
 +If you exit (\\[keyboard-quit], RET or q), you can resume the query replace
 +with the command \\[tags-loop-continue].
 +Fourth arg FILE-LIST-FORM non-nil means initialize the replacement loop.
 +Fifth and sixth arguments START and END are accepted, for compatibility
 +with `query-replace-regexp', and ignored.
 +
 +If FILE-LIST-FORM is non-nil, it is a form to evaluate to
 +produce the list of files to search.
 +
 +See also the documentation of the variable `tags-file-name'."
 +  (interactive (query-replace-read-args "Tags query replace (regexp)" t t))
 +  (setq tags-loop-scan `(let ,(unless (equal from (downcase from))
 +				'((case-fold-search nil)))
 +			  (if (re-search-forward ',from nil t)
 +			      ;; When we find a match, move back
 +			      ;; to the beginning of it so perform-replace
 +			      ;; will see it.
 +			      (goto-char (match-beginning 0))))
 +	tags-loop-operate `(perform-replace ',from ',to t t ',delimited
 +					    nil multi-query-replace-map))
 +  (tags-loop-continue (or file-list-form t)))
 +
 +(defun tags-complete-tags-table-file (string predicate what) ; Doc string?
 +  (save-excursion
 +    ;; If we need to ask for the tag table, allow that.
 +    (let ((enable-recursive-minibuffers t))
 +      (visit-tags-table-buffer))
 +    (if (eq what t)
 +	(all-completions string (tags-table-files) predicate)
 +      (try-completion string (tags-table-files) predicate))))
 +
 +;;;###autoload
 +(defun list-tags (file &optional _next-match)
 +  "Display list of tags in file FILE.
 +This searches only the first table in the list, and no included tables.
 +FILE should be as it appeared in the `etags' command, usually without a
 +directory specification."
 +  (interactive (list (completing-read "List tags in file: "
 +				      'tags-complete-tags-table-file
 +				      nil t nil)))
 +  (with-output-to-temp-buffer "*Tags List*"
 +    (princ "Tags in file `")
 +    (tags-with-face 'highlight (princ file))
 +    (princ "':\n\n")
 +    (save-excursion
 +      (let ((first-time t)
 +	    (gotany nil))
 +	(while (visit-tags-table-buffer (not first-time))
 +	  (setq first-time nil)
 +	  (if (funcall list-tags-function file)
 +	      (setq gotany t)))
 +	(or gotany
 +	    (user-error "File %s not in current tags tables" file)))))
 +  (with-current-buffer "*Tags List*"
 +    (require 'apropos)
 +    (with-no-warnings
 +      (apropos-mode))
 +    (setq buffer-read-only t)))
 +
 +;;;###autoload
 +(defun tags-apropos (regexp)
 +  "Display list of all tags in tags table REGEXP matches."
 +  (declare (obsolete xref-find-apropos "25.1"))
 +  (interactive "sTags apropos (regexp): ")
 +  (with-output-to-temp-buffer "*Tags List*"
 +    (princ "Click mouse-2 to follow tags.\n\nTags matching regexp `")
 +    (tags-with-face 'highlight (princ regexp))
 +    (princ "':\n\n")
 +    (save-excursion
 +      (let ((first-time t))
 +	(while (visit-tags-table-buffer (not first-time))
 +	  (setq first-time nil)
 +	  (funcall tags-apropos-function regexp))))
 +    (etags-tags-apropos-additional regexp))
 +  (with-current-buffer "*Tags List*"
 +    (eval-and-compile (require 'apropos))
 +    (apropos-mode)
 +    ;; apropos-mode is derived from fundamental-mode and it kills
 +    ;; all local variables.
 +    (setq buffer-read-only t)))
 +
 +;; XXX Kludge interface.
 +
 +(define-button-type 'tags-select-tags-table
 +  'action 'select-tags-table-select
 +  'follow-link t
 +  'help-echo "RET, t or mouse-2: select tags table")
 +
 +;; XXX If a file is in multiple tables, selection may get the wrong one.
 +;;;###autoload
 +(defun select-tags-table ()
 +  "Select a tags table file from a menu of those you have already used.
 +The list of tags tables to select from is stored in `tags-table-set-list';
 +see the doc of that variable if you want to add names to the list."
 +  (interactive)
 +  (pop-to-buffer "*Tags Table List*")
 +  (setq buffer-read-only nil
 +	buffer-undo-list t)
 +  (erase-buffer)
 +  (let ((set-list tags-table-set-list)
 +	(desired-point nil)
 +	b)
 +    (when tags-table-list
 +      (setq desired-point (point-marker))
 +      (setq b (point))
 +      (princ (mapcar 'abbreviate-file-name tags-table-list) (current-buffer))
 +      (make-text-button b (point) 'type 'tags-select-tags-table
 +                        'etags-table (car tags-table-list))
 +      (insert "\n"))
 +    (while set-list
 +      (unless (eq (car set-list) tags-table-list)
 +	(setq b (point))
 +	(princ (mapcar 'abbreviate-file-name (car set-list)) (current-buffer))
 +	(make-text-button b (point) 'type 'tags-select-tags-table
 +                          'etags-table (car (car set-list)))
 +	(insert "\n"))
 +      (setq set-list (cdr set-list)))
 +    (when tags-file-name
 +      (or desired-point
 +          (setq desired-point (point-marker)))
 +      (setq b (point))
 +      (insert (abbreviate-file-name tags-file-name))
 +      (make-text-button b (point) 'type 'tags-select-tags-table
 +                        'etags-table tags-file-name)
 +      (insert "\n"))
 +    (setq set-list (delete tags-file-name
 +			   (apply 'nconc (cons (copy-sequence tags-table-list)
 +					       (mapcar 'copy-sequence
 +						       tags-table-set-list)))))
 +    (while set-list
 +      (setq b (point))
 +      (insert (abbreviate-file-name (car set-list)))
 +      (make-text-button b (point) 'type 'tags-select-tags-table
 +                          'etags-table (car set-list))
 +      (insert "\n")
 +      (setq set-list (delete (car set-list) set-list)))
 +    (goto-char (point-min))
 +    (insert-before-markers
 +     "Type `t' to select a tags table or set of tags tables:\n\n")
 +    (if desired-point
 +	(goto-char desired-point))
 +    (set-window-start (selected-window) 1 t))
 +  (set-buffer-modified-p nil)
 +  (select-tags-table-mode))
 +
 +(defvar select-tags-table-mode-map ; Doc string?
 +  (let ((map (make-sparse-keymap)))
 +    (set-keymap-parent map button-buffer-map)
 +    (define-key map "t" 'push-button)
 +    (define-key map " " 'next-line)
 +    (define-key map "\^?" 'previous-line)
 +    (define-key map "n" 'next-line)
 +    (define-key map "p" 'previous-line)
 +    (define-key map "q" 'select-tags-table-quit)
 +    map))
 +
 +(define-derived-mode select-tags-table-mode special-mode "Select Tags Table"
 +  "Major mode for choosing a current tags table among those already loaded."
 +  (setq buffer-read-only t))
 +
 +(defun select-tags-table-select (button)
 +  "Select the tags table named on this line."
 +  (interactive (list (or (button-at (line-beginning-position))
 +                         (error "No tags table on current line"))))
 +  (let ((name (button-get button 'etags-table)))
 +    (visit-tags-table name)
 +    (select-tags-table-quit)
 +    (message "Tags table now %s" name)))
 +
 +(defun select-tags-table-quit ()
 +  "Kill the buffer and delete the selected window."
 +  (interactive)
 +  (quit-window t (selected-window)))
 +
 +;;;###autoload
 +(defun complete-tag ()
 +  "Perform tags completion on the text around point.
 +Completes to the set of names listed in the current tags table.
 +The string to complete is chosen in the same way as the default
 +for \\[find-tag] (which see)."
 +  (interactive)
 +  (or tags-table-list
 +      tags-file-name
 +      (user-error "%s"
 +                  (substitute-command-keys
 +                   "No tags table loaded; try \\[visit-tags-table]")))
 +  (let ((comp-data (tags-completion-at-point-function)))
 +    (if (null comp-data)
 +	(user-error "Nothing to complete")
 +      (completion-in-region (car comp-data) (cadr comp-data)
 +			    (nth 2 comp-data)
 +			    (plist-get (nthcdr 3 comp-data) :predicate)))))
 +
 +
 +;;; Xref backend
 +
 +;; Stop searching if we find more than xref-limit matches, as the xref
 +;; infrastructure is not designed to handle very long lists.
 +;; Switching to some kind of lazy list might be better, but hopefully
 +;; we hit the limit rarely.
 +(defconst etags--xref-limit 1000)
 +
 +(defvar etags-xref-find-definitions-tag-order '(tag-exact-match-p
 +                                                tag-implicit-name-match-p
 +                                                tag-symbol-match-p)
 +  "Tag order used in `etags-xref-find' to look for definitions.")
 +
 +;;;###autoload
 +(defun etags-xref-find (action id)
 +  (pcase action
 +    (`definitions (etags--xref-find-definitions id))
 +    (`references
 +     (let ((dirs (if tags-table-list
 +                     (mapcar #'file-name-directory tags-table-list)
 +                   ;; If no tags files are loaded, prompt for the dir.
 +                   (list (read-directory-name "In directory: " nil nil t)))))
 +       (cl-mapcan
 +        (lambda (dir)
 +          (xref-collect-references id dir))
 +        dirs)))
 +    (`apropos (etags--xref-find-definitions id t))))
 +
 +(defun etags--xref-find-definitions (pattern &optional regexp?)
 +  ;; This emulates the behavior of `find-tag-in-order' but instead of
 +  ;; returning one match at a time all matches are returned as list.
 +  ;; NOTE: find-tag-tag-order is typically a buffer-local variable.
 +  (let* ((xrefs '())
 +         (first-time t)
 +         (search-fun (if regexp? #'re-search-forward #'search-forward))
 +         (marks (make-hash-table :test 'equal))
 +         (case-fold-search (if (memq tags-case-fold-search '(nil t))
 +                               tags-case-fold-search
 +                             case-fold-search)))
 +    (save-excursion
 +      (while (visit-tags-table-buffer (not first-time))
 +        (setq first-time nil)
 +        (dolist (order-fun (cond (regexp? find-tag-regexp-tag-order)
 +                                 (t etags-xref-find-definitions-tag-order)))
 +          (goto-char (point-min))
 +          (while (and (funcall search-fun pattern nil t)
 +                      (< (hash-table-count marks) etags--xref-limit))
 +            (when (funcall order-fun pattern)
 +              (beginning-of-line)
 +              (pcase-let* ((tag-info (etags-snarf-tag))
 +                           (`(,hint ,line . _) tag-info))
 +                (unless (eq hint t) ; hint==t if we are in a filename line
 +                  (let* ((file (file-of-tag))
 +                         (mark-key (cons file line)))
 +                    (unless (gethash mark-key marks)
 +                      (let ((loc (xref-make-etags-location
 +                                  tag-info (expand-file-name file))))
 +                        (push (xref-make hint loc) xrefs)
 +                        (puthash mark-key t marks)))))))))))
 +    (nreverse xrefs)))
 +
 +(defclass xref-etags-location (xref-location)
 +  ((tag-info :type list   :initarg :tag-info)
 +   (file     :type string :initarg :file
 +             :reader xref-location-group))
 +  :documentation "Location of an etags tag.")
 +
 +(defun xref-make-etags-location (tag-info file)
 +  (make-instance 'xref-etags-location :tag-info tag-info
 +                 :file (expand-file-name file)))
 +
 +(cl-defmethod xref-location-marker ((l xref-etags-location))
 +  (with-slots (tag-info file) l
 +    (let ((buffer (find-file-noselect file)))
 +      (with-current-buffer buffer
 +        (etags-goto-tag-location tag-info)
 +        (point-marker)))))
 +
 +(cl-defmethod xref-location-line ((l xref-etags-location))
 +  (with-slots (tag-info) l
 +    (nth 1 tag-info)))
 +
 +
 +(provide 'etags)
 +
 +;;; etags.el ends here
diff --cc test/manual/etags/tex-src/texinfo.tex
index aa745c68471,00000000000..e98f24cda69
mode 100644,000000..100644
--- a/test/manual/etags/tex-src/texinfo.tex
+++ b/test/manual/etags/tex-src/texinfo.tex
@@@ -1,3351 -1,0 +1,3351 @@@
 +%% TeX macros to handle texinfo files
 +
- %   Copyright (C) 1985-1986, 1988, 1990-1991, 2016 Free Software
++%   Copyright (C) 1985-1986, 1988, 1990-1991, 2016-2017 Free Software
 +%   Foundation, Inc.
 +
 +%This texinfo.tex file is free software; you can redistribute it and/or
 +%modify it under the terms of the GNU General Public License as
 +%published by the Free Software Foundation; either version 2, or (at
 +%your option) any later version.
 +
 +%This texinfo.tex file is distributed in the hope that it will be
 +%useful, but WITHOUT ANY WARRANTY; without even the implied warranty
 +%of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 +%General Public License for more details.
 +
 +%You should have received a copy of the GNU General Public License
 +%along with this texinfo.tex file; see the file COPYING.  If not, write
 +%to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139,
 +%USA.
 +
 +
 +%In other words, you are welcome to use, share and improve this program.
 +%You are forbidden to forbid anyone else to use, share and improve
 +%what you give them.   Help stamp out software-hoarding!
 +
 +\def\texinfoversion{2.73}
 +\message{Loading texinfo package [Version \texinfoversion]:}
 +\message{}
 +
 +% Print the version number if in a .fmt file.
 +\everyjob{\message{[Texinfo version \texinfoversion]}\message{}}
 +
 +% Save some parts of plain tex whose names we will redefine.
 +
 +\let\ptexlbrace=\{
 +\let\ptexrbrace=\}
 +\let\ptexdots=\dots
 +\let\ptexdot=\.
 +\let\ptexstar=\*
 +\let\ptexend=\end
 +\let\ptexbullet=\bullet
 +\let\ptexb=\b
 +\let\ptexc=\c
 +\let\ptexi=\i
 +\let\ptext=\t
 +\let\ptexl=\l
 +\let\ptexL=\L
 +
 +\def\tie{\penalty 10000\ }     % Save plain tex definition of ~.
 +
 +\message{Basics,}
 +\chardef\other=12
 +
 +% If this character appears in an error message or help string, it
 +% starts a new line in the output.
 +\newlinechar = `^^J
 +
 +\hyphenation{ap-pen-dix}
 +\hyphenation{mini-buf-fer mini-buf-fers}
 +\hyphenation{eshell}
 +
 +% Margin to add to right of even pages, to left of odd pages.
 +\newdimen \bindingoffset  \bindingoffset=0pt
 +\newdimen \normaloffset   \normaloffset=\hoffset
 +\newdimen\pagewidth \newdimen\pageheight
 +\pagewidth=\hsize \pageheight=\vsize
 +
 +% Sometimes it is convenient to have everything in the transcript file
 +% and nothing on the terminal.  We don't just call \tracingall here,
 +% since that produces some useless output on the terminal.
 +%
 +\def\gloggingall{\begingroup \globaldefs = 1 \loggingall \endgroup}%
 +\def\loggingall{\tracingcommands2 \tracingstats2 
 +   \tracingpages1 \tracingoutput1 \tracinglostchars1 
 +   \tracingmacros2 \tracingparagraphs1 \tracingrestores1 
 +   \showboxbreadth\maxdimen\showboxdepth\maxdimen
 +}%
 +
 +%---------------------Begin change-----------------------
 +%
 +%%%% For @cropmarks command.
 +% Dimensions to add cropmarks at corners Added by P. A. MacKay, 12 Nov. 1986
 +%
 +\newdimen\cornerlong \newdimen\cornerthick
 +\newdimen \topandbottommargin
 +\newdimen \outerhsize \newdimen \outervsize
 +\cornerlong=1pc\cornerthick=.3pt	% These set size of cropmarks
 +\outerhsize=7in
 +%\outervsize=9.5in
 +% Alternative @smallbook page size is 9.25in
 +\outervsize=9.25in
 +\topandbottommargin=.75in
 +%
 +%---------------------End change-----------------------
 +
 +% \onepageout takes a vbox as an argument.  Note that \pagecontents
 +% does insertions itself, but you have to call it yourself.
 +\chardef\PAGE=255  \output={\onepageout{\pagecontents\PAGE}}
 +\def\onepageout#1{\hoffset=\normaloffset
 +\ifodd\pageno  \advance\hoffset by \bindingoffset
 +\else \advance\hoffset by -\bindingoffset\fi
 +{\escapechar=`\\\relax % makes sure backslash is used in output files.
 +\shipout\vbox{{\let\hsize=\pagewidth \makeheadline} \pagebody{#1}%
 +{\let\hsize=\pagewidth \makefootline}}}%
 +\advancepageno \ifnum\outputpenalty>-20000 \else\dosupereject\fi}
 +
 +%%%% For @cropmarks command %%%%
 +
 +% Here is a modification of the main output routine for Near East Publications
 +% This provides right-angle cropmarks at all four corners.
 +% The contents of the page are centerlined into the cropmarks,
 +% and any desired binding offset is added as an \hskip on either
 +% site of the centerlined box.  (P. A. MacKay, 12 November, 1986)
 +%
 +\def\croppageout#1{\hoffset=0pt % make sure this doesn't mess things up
 +		 \shipout
 +		 \vbox to \outervsize{\hsize=\outerhsize
 +                 \vbox{\line{\ewtop\hfill\ewtop}}
 +                 \nointerlineskip
 +                 \line{\vbox{\moveleft\cornerthick\nstop}
 +                       \hfill
 +                       \vbox{\moveright\cornerthick\nstop}}
 +                 \vskip \topandbottommargin
 +                 \centerline{\ifodd\pageno\hskip\bindingoffset\fi
 +			\vbox{
 +			{\let\hsize=\pagewidth \makeheadline}
 +			\pagebody{#1}
 +			{\let\hsize=\pagewidth \makefootline}}
 +			\ifodd\pageno\else\hskip\bindingoffset\fi}
 +		 \vskip \topandbottommargin plus1fill minus1fill
 +                 \boxmaxdepth\cornerthick
 +                 \line{\vbox{\moveleft\cornerthick\nsbot}
 +                       \hfill
 +                       \vbox{\moveright\cornerthick\nsbot}}
 +                 \nointerlineskip
 +                 \vbox{\line{\ewbot\hfill\ewbot}}
 +	}
 +  \advancepageno 
 +  \ifnum\outputpenalty>-20000 \else\dosupereject\fi}
 +%
 +% Do @cropmarks to get crop marks
 +\def\cropmarks{\let\onepageout=\croppageout }
 +
 +\def\pagebody#1{\vbox to\pageheight{\boxmaxdepth=\maxdepth #1}}
 +{\catcode`\@ =11
 +\gdef\pagecontents#1{\ifvoid\topins\else\unvbox\topins\fi
 +\dimen@=\dp#1 \unvbox#1
 +\ifvoid\footins\else\vskip\skip\footins\footnoterule \unvbox\footins\fi
 +\ifr@ggedbottom \kern-\dimen@ \vfil \fi}
 +}
 +
 +%
 +% Here are the rules for the cropmarks.  Note that they are
 +% offset so that the space between them is truly \outerhsize or \outervsize
 +% (P. A. MacKay, 12 November, 1986)
 +%
 +\def\ewtop{\vrule height\cornerthick depth0pt width\cornerlong}
 +\def\nstop{\vbox
 +  {\hrule height\cornerthick depth\cornerlong width\cornerthick}}
 +\def\ewbot{\vrule height0pt depth\cornerthick width\cornerlong}
 +\def\nsbot{\vbox
 +  {\hrule height\cornerlong depth\cornerthick width\cornerthick}}
 +
 +% Parse an argument, then pass it to #1.
 +% The argument can be delimited with [...] or with "..." or braces
 +% or it can be a whole line.
 +% #1 should be a macro which expects
 +% an ordinary undelimited TeX argument.
 +
 +\def\parsearg #1{\let\next=#1\begingroup\obeylines\futurelet\temp\parseargx}
 +
 +\def\parseargx{%
 +\ifx \obeyedspace\temp \aftergroup\parseargdiscardspace \else%
 +\aftergroup \parseargline %
 +\fi \endgroup}
 +
 +{\obeyspaces %
 +\gdef\parseargdiscardspace {\begingroup\obeylines\futurelet\temp\parseargx}}
 +
 +\gdef\obeyedspace{\ }
 +
 +\def\parseargline{\begingroup \obeylines \parsearglinex}
 +{\obeylines %
 +\gdef\parsearglinex #1^^M{\endgroup \next {#1}}}
 +
 +\def\flushcr{\ifx\par\lisppar \def\next##1{}\else \let\next=\relax \fi \next}
 +
 +%% These are used to keep @begin/@end levels from running away
 +%% Call \inENV within environments (after a \begingroup)
 +\newif\ifENV \ENVfalse \def\inENV{\ifENV\relax\else\ENVtrue\fi}
 +\def\ENVcheck{%
 +\ifENV\errmessage{Still within an environment.  Type Return to continue.}
 +\endgroup\fi} % This is not perfect, but it should reduce lossage
 +
 +% @begin foo  is the same as @foo, for now.
 +\newhelp\EMsimple{Type <Return> to continue}
 +
 +\outer\def\begin{\parsearg\beginxxx}
 +
 +\def\beginxxx #1{%
 +\expandafter\ifx\csname #1\endcsname\relax
 +{\errhelp=\EMsimple \errmessage{Undefined command @begin #1}}\else
 +\csname #1\endcsname\fi}
 +
 +%% @end foo executes the definition of \Efoo.
 +%% foo can be delimited by doublequotes or brackets.
 +
 +\def\end{\parsearg\endxxx}
 +
 +\def\endxxx #1{%
 +\expandafter\ifx\csname E#1\endcsname\relax
 +\expandafter\ifx\csname #1\endcsname\relax
 +\errmessage{Undefined command @end #1}\else
 +\errorE{#1}\fi\fi
 +\csname E#1\endcsname}
 +\def\errorE#1{
 +{\errhelp=\EMsimple \errmessage{@end #1 not within #1 environment}}}
 +
 +% Single-spacing is done by various environments.
 +
 +\newskip\singlespaceskip \singlespaceskip = \baselineskip
 +\def\singlespace{%
 +{\advance \baselineskip by -\singlespaceskip
 +\kern \baselineskip}%
 +\baselineskip=\singlespaceskip
 +}
 +
 +%% Simple single-character @ commands
 +
 +% @@ prints an @
 +% Kludge this until the fonts are right (grr).
 +\def\@{{\tt \char '100}}
 +
 +% Define @` and @' to be the same as ` and '
 +% but suppressing ligatures.
 +\def\`{{`}}
 +\def\'{{'}}
 +
 +% Used to generate quoted braces.
 +
 +\def\mylbrace {{\tt \char '173}}
 +\def\myrbrace {{\tt \char '175}}
 +\let\{=\mylbrace
 +\let\}=\myrbrace
 +
 +% @: forces normal size whitespace following.
 +\def\:{\spacefactor=1000 }
 +
 +% @* forces a line break.
 +\def\*{\hfil\break\hbox{}\ignorespaces}
 +
 +% @. is an end-of-sentence period.
 +\def\.{.\spacefactor=3000 }
 +
 +% @w prevents a word break.  Without the \leavevmode, @w at the
 +% beginning of a paragraph, when TeX is still in vertical mode, would
 +% produce a whole line of output instead of starting the paragraph.
 +\def\w#1{\leavevmode\hbox{#1}}
 +
 +% @group ... @end group forces ... to be all on one page, by enclosing
 +% it in a TeX vbox.  We use \vtop instead of \vbox to construct the box
 +% to keep its height that of a normal line.  According to the rules for
 +% \topskip (p.114 of the TeXbook), the glue inserted is
 +% max (\topskip - \ht (first item), 0).  If that height is large,
 +% therefore, no glue is inserted, and the space between the headline and
 +% the text is small, which looks bad.
 +% 
 +\def\group{\begingroup
 +  \ifnum\catcode13=\active \else
 +    \errhelp = \groupinvalidhelp
 +    \errmessage{@group invalid in context where filling is enabled}%
 +  \fi
 +  \def\Egroup{\egroup\endgroup}%
 +  \vtop\bgroup
 +}
 +%
 +% TeX puts in an \escapechar (i.e., `@') at the beginning of the help
 +% message, so this ends up printing `@group can only ...'.
 +% 
 +\newhelp\groupinvalidhelp{%
 +group can only be used in environments such as @example,^^J%
 +where each line of input produces a line of output.}
 +
 +% @need space-in-mils
 +% forces a page break if there is not space-in-mils remaining.
 +
 +\newdimen\mil  \mil=0.001in
 +
 +\def\need{\parsearg\needx}
 +
 +% Old definition--didn't work.
 +%\def\needx #1{\par %
 +%% This method tries to make TeX break the page naturally
 +%% if the depth of the box does not fit.
 +%{\baselineskip=0pt%
 +%\vtop to #1\mil{\vfil}\kern -#1\mil\penalty 10000
 +%\prevdepth=-1000pt
 +%}}
 +
 +\def\needx#1{%
 +  % Go into vertical mode, so we don't make a big box in the middle of a
 +  % paragraph.
 +  \par
 +  %
 +  % Don't add any leading before our big empty box, but allow a page
 +  % break, since the best break might be right here.
 +  \allowbreak
 +  \nointerlineskip
 +  \vtop to #1\mil{\vfil}%
 +  % 
 +  % TeX does not even consider page breaks if a penalty added to the
 +  % main vertical list is 10000 or more.  But in order to see if the
 +  % empty box we just added fits on the page, we must make it consider
 +  % page breaks.  On the other hand, we don't want to actually break the
 +  % page after the empty box.  So we use a penalty of 9999.
 +  % 
 +  % There is an extremely small chance that TeX will actually break the
 +  % page at this \penalty, if there are no other feasible breakpoints in
 +  % sight.  (If the user is using lots of big @group commands, which
 +  % almost-but-not-quite fill up a page, TeX will have a hard time doing
 +  % good page breaking, for example.)  However, I could not construct an
 +  % example where a page broke at this \penalty; if it happens in a real
 +  % document, then we can reconsider our strategy.
 +  \penalty9999
 +  %
 +  % Back up by the size of the box, whether we did a page break or not.
 +  \kern -#1\mil
 +  %
 +  % Do not allow a page break right after this kern.
 +  \nobreak
 +}
 +
 +% @br   forces paragraph break
 +
 +\let\br = \par
 +
 +% @dots{}  output some dots
 +
 +\def\dots{$\ldots$}
 +
 +% @page    forces the start of a new page
 +
 +\def\page{\par\vfill\supereject}
 +
 +% @exdent text....
 +% outputs text on separate line in roman font, starting at standard page margin
 +
 +% This records the amount of indent in the innermost environment.
 +% That's how much \exdent should take out.
 +\newskip\exdentamount
 +
 +% This defn is used inside fill environments such as @defun.
 +\def\exdent{\parsearg\exdentyyy}
 +\def\exdentyyy #1{{\hfil\break\hbox{\kern -\exdentamount{\rm#1}}\hfil\break}}
 +
 +% This defn is used inside nofill environments such as @example.
 +\def\nofillexdent{\parsearg\nofillexdentyyy}
 +\def\nofillexdentyyy #1{{\advance \leftskip by -\exdentamount
 +\leftline{\hskip\leftskip{\rm#1}}}}
 +
 +%\hbox{{\rm#1}}\hfil\break}}
 +
 +% @include file    insert text of that file as input.
 +
 +\def\include{\parsearg\includezzz}
 +\def\includezzz #1{{\def\thisfile{#1}\input #1
 +}}
 +
 +\def\thisfile{}
 +
 +% @center line   outputs that line, centered
 +
 +\def\center{\parsearg\centerzzz}
 +\def\centerzzz #1{{\advance\hsize by -\leftskip
 +\advance\hsize by -\rightskip
 +\centerline{#1}}}
 +
 +% @sp n   outputs n lines of vertical space
 +
 +\def\sp{\parsearg\spxxx}
 +\def\spxxx #1{\par \vskip #1\baselineskip}
 +
 +% @comment ...line which is ignored...
 +% @c is the same as @comment
 +% @ignore ... @end ignore  is another way to write a comment
 +
 +\def\comment{\catcode 64=\other \catcode 123=\other \catcode 125=\other%
 +\parsearg \commentxxx}
 +
 +\def\commentxxx #1{\catcode 64=0 \catcode 123=1 \catcode 125=2 }
 +
 +\let\c=\comment
 +
 +% Prevent errors for section commands.
 +% Used in @ignore and in failing conditionals.
 +\def\ignoresections{%
 +\let\chapter=\relax
 +\let\unnumbered=\relax
 +\let\top=\relax
 +\let\unnumberedsec=\relax
 +\let\unnumberedsection=\relax
 +\let\unnumberedsubsec=\relax
 +\let\unnumberedsubsection=\relax
 +\let\unnumberedsubsubsec=\relax
 +\let\unnumberedsubsubsection=\relax
 +\let\section=\relax
 +\let\subsec=\relax
 +\let\subsubsec=\relax
 +\let\subsection=\relax
 +\let\subsubsection=\relax
 +\let\appendix=\relax
 +\let\appendixsec=\relax
 +\let\appendixsection=\relax
 +\let\appendixsubsec=\relax
 +\let\appendixsubsection=\relax
 +\let\appendixsubsubsec=\relax
 +\let\appendixsubsubsection=\relax
 +\let\contents=\relax
 +\let\smallbook=\relax
 +\let\titlepage=\relax
 +}
 +
 +\def\ignore{\begingroup\ignoresections
 +% Make sure that spaces turn into tokens that match what \ignorexxx wants.
 +\catcode32=10
 +\ignorexxx}
 +\long\def\ignorexxx #1\end ignore{\endgroup\ignorespaces}
 +
 +\def\direntry{\begingroup\direntryxxx}
 +\long\def\direntryxxx #1\end direntry{\endgroup\ignorespaces}
 +
 +% Conditionals to test whether a flag is set.
 +
 +\def\ifset{\begingroup\ignoresections\parsearg\ifsetxxx}
 +
 +\def\ifsetxxx #1{\endgroup
 +\expandafter\ifx\csname IF#1\endcsname\relax \let\temp=\ifsetfail
 +\else \let\temp=\relax \fi
 +\temp}
 +\def\Eifset{}
 +\def\ifsetfail{\begingroup\ignoresections\ifsetfailxxx}
 +\long\def\ifsetfailxxx #1\end ifset{\endgroup\ignorespaces}
 +
 +\def\ifclear{\begingroup\ignoresections\parsearg\ifclearxxx}
 +
 +\def\ifclearxxx #1{\endgroup
 +\expandafter\ifx\csname IF#1\endcsname\relax \let\temp=\relax
 +\else \let\temp=\ifclearfail \fi
 +\temp}
 +\def\Eifclear{}
 +\def\ifclearfail{\begingroup\ignoresections\ifclearfailxxx}
 +\long\def\ifclearfailxxx #1\end ifclear{\endgroup\ignorespaces}
 +
 +% @set foo     to set the flag named foo.
 +% @clear foo   to clear the flag named foo.
 +\def\set{\parsearg\setxxx}
 +\def\setxxx #1{
 +\expandafter\let\csname IF#1\endcsname=\set}
 +
 +\def\clear{\parsearg\clearxxx}
 +\def\clearxxx #1{
 +\expandafter\let\csname IF#1\endcsname=\relax}
 +
 +% Some texinfo constructs that are trivial in tex
 +
 +\def\iftex{}
 +\def\Eiftex{}
 +\def\ifinfo{\begingroup\ignoresections\ifinfoxxx}
 +\long\def\ifinfoxxx #1\end ifinfo{\endgroup\ignorespaces}
 +
 +\long\def\menu #1\end menu{}
 +\def\asis#1{#1}
 +
 +% @math means output in math mode.
 +% We don't use $'s directly in the definition of \math because control
 +% sequences like \math are expanded when the toc file is written.  Then,
 +% we read the toc file back, the $'s will be normal characters (as they
 +% should be, according to the definition of Texinfo).  So we must use a
 +% control sequence to switch into and out of math mode.
 +% 
 +% This isn't quite enough for @math to work properly in indices, but it
 +% seems unlikely it will ever be needed there.
 +% 
 +\let\implicitmath = $
 +\def\math#1{\implicitmath #1\implicitmath}
 +
 +\def\node{\ENVcheck\parsearg\nodezzz}
 +\def\nodezzz#1{\nodexxx [#1,]}
 +\def\nodexxx[#1,#2]{\gdef\lastnode{#1}}
 +\let\lastnode=\relax
 +
 +\def\donoderef{\ifx\lastnode\relax\else
 +\expandafter\expandafter\expandafter\setref{\lastnode}\fi
 +\let\lastnode=\relax}
 +
 +\def\unnumbnoderef{\ifx\lastnode\relax\else
 +\expandafter\expandafter\expandafter\unnumbsetref{\lastnode}\fi
 +\let\lastnode=\relax}
 +
 +\def\appendixnoderef{\ifx\lastnode\relax\else
 +\expandafter\expandafter\expandafter\appendixsetref{\lastnode}\fi
 +\let\lastnode=\relax}
 +
 +\let\refill=\relax
 +  
 +% @setfilename is done at the beginning of every texinfo file.
 +% So open here the files we need to have open while reading the input.
 +% This makes it possible to make a .fmt file for texinfo.
 +\def\setfilename{%
 +   \readauxfile
 +   \opencontents
 +   \openindices
 +   \fixbackslash  % Turn off hack to swallow `\input texinfo'.
 +   \global\let\setfilename=\comment % Ignore extra @setfilename cmds.
 +   \comment % Ignore the actual filename.
 +}
 +
 +\outer\def\bye{\pagealignmacro\tracingstats=1\ptexend}
 +
 +\def\inforef #1{\inforefzzz #1,,,,**}
 +\def\inforefzzz #1,#2,#3,#4**{See Info file \file{\losespace#3{}},
 +  node \samp{\losespace#1{}}}
 +\def\losespace #1{#1}
 +
 +\message{fonts,}
 +
 +% Font-change commands.
 +
 +% Texinfo supports the sans serif font style, which plain TeX does not.
 +% So we set up a \sf analogous to plain's \rm, etc.
 +\newfam\sffam
 +\def\sf{\fam=\sffam \tensf}
 +\let\li = \sf % Sometimes we call it \li, not \sf.
 +
 +%% Try out Computer Modern fonts at \magstephalf
 +\let\mainmagstep=\magstephalf
 +
 +\ifx\bigger\relax
 +\let\mainmagstep=\magstep1
 +\font\textrm=cmr12
 +\font\texttt=cmtt12
 +\else
 +\font\textrm=cmr10 scaled \mainmagstep
 +\font\texttt=cmtt10 scaled \mainmagstep
 +\fi
 +% Instead of cmb10, you many want to use cmbx10.
 +% cmbx10 is a prettier font on its own, but cmb10
 +% looks better when embedded in a line with cmr10.
 +\font\textbf=cmb10 scaled \mainmagstep 
 +\font\textit=cmti10 scaled \mainmagstep
 +\font\textsl=cmsl10 scaled \mainmagstep
 +\font\textsf=cmss10 scaled \mainmagstep
 +\font\textsc=cmcsc10 scaled \mainmagstep
 +\font\texti=cmmi10 scaled \mainmagstep
 +\font\textsy=cmsy10 scaled \mainmagstep
 +
 +% A few fonts for @defun, etc.
 +\font\defbf=cmbx10 scaled \magstep1 %was 1314
 +\font\deftt=cmtt10 scaled \magstep1
 +\def\df{\let\tentt=\deftt \let\tenbf = \defbf \bf}
 +
 +% Fonts for indices and small examples.
 +% We actually use the slanted font rather than the italic, 
 +% because texinfo normally uses the slanted fonts for that.
 +% Do not make many font distinctions in general in the index, since they
 +% aren't very useful.
 +\font\ninett=cmtt9
 +\font\indrm=cmr9
 +\font\indit=cmsl9
 +\let\indsl=\indit
 +\let\indtt=\ninett
 +\let\indsf=\indrm
 +\let\indbf=\indrm
 +\let\indsc=\indrm
 +\font\indi=cmmi9
 +\font\indsy=cmsy9
 +
 +% Fonts for headings
 +\font\chaprm=cmbx12 scaled \magstep2
 +\font\chapit=cmti12 scaled \magstep2
 +\font\chapsl=cmsl12 scaled \magstep2
 +\font\chaptt=cmtt12 scaled \magstep2
 +\font\chapsf=cmss12 scaled \magstep2
 +\let\chapbf=\chaprm
 +\font\chapsc=cmcsc10 scaled\magstep3
 +\font\chapi=cmmi12 scaled \magstep2
 +\font\chapsy=cmsy10 scaled \magstep3
 +
 +\font\secrm=cmbx12 scaled \magstep1
 +\font\secit=cmti12 scaled \magstep1
 +\font\secsl=cmsl12 scaled \magstep1
 +\font\sectt=cmtt12 scaled \magstep1
 +\font\secsf=cmss12 scaled \magstep1
 +\font\secbf=cmbx12 scaled \magstep1
 +\font\secsc=cmcsc10 scaled\magstep2
 +\font\seci=cmmi12 scaled \magstep1
 +\font\secsy=cmsy10 scaled \magstep2
 +
 +% \font\ssecrm=cmbx10 scaled \magstep1    % This size an font looked bad.
 +% \font\ssecit=cmti10 scaled \magstep1    % The letters were too crowded.
 +% \font\ssecsl=cmsl10 scaled \magstep1
 +% \font\ssectt=cmtt10 scaled \magstep1
 +% \font\ssecsf=cmss10 scaled \magstep1
 +
 +%\font\ssecrm=cmb10 scaled 1315	% Note the use of cmb rather than cmbx.
 +%\font\ssecit=cmti10 scaled 1315	% Also, the size is a little larger than
 +%\font\ssecsl=cmsl10 scaled 1315	% being scaled magstep1.
 +%\font\ssectt=cmtt10 scaled 1315
 +%\font\ssecsf=cmss10 scaled 1315
 +
 +%\let\ssecbf=\ssecrm
 +
 +\font\ssecrm=cmbx12 scaled \magstephalf
 +\font\ssecit=cmti12 scaled \magstephalf
 +\font\ssecsl=cmsl12 scaled \magstephalf
 +\font\ssectt=cmtt12 scaled \magstephalf
 +\font\ssecsf=cmss12 scaled \magstephalf
 +\font\ssecbf=cmbx12 scaled \magstephalf
 +\font\ssecsc=cmcsc10 scaled \magstep1 
 +\font\sseci=cmmi12 scaled \magstephalf
 +\font\ssecsy=cmsy10 scaled \magstep1
 +% The smallcaps and symbol fonts should actually be scaled \magstep1.5,
 +% but that is not a standard magnification.
 +
 +% Fonts for title page:
 +\font\titlerm = cmbx12 scaled \magstep3
 +\let\authorrm = \secrm
 +
 +% In order for the font changes to affect most math symbols and letters,
 +% we have to define the \textfont of the standard families.  Since
 +% texinfo doesn't allow for producing subscripts and superscripts, we
 +% don't bother to reset \scriptfont and \scriptscriptfont (which would
 +% also require loading a lot more fonts).
 +% 
 +\def\resetmathfonts{%
 +  \textfont0 = \tenrm \textfont1 = \teni \textfont2 = \tensy
 +  \textfont\itfam = \tenit \textfont\slfam = \tensl \textfont\bffam = \tenbf
 +  \textfont\ttfam = \tentt \textfont\sffam = \tensf
 +}
 +
 +
 +% The font-changing commands redefine the meanings of \tenSTYLE, instead
 +% of just \STYLE.  We do this so that font changes will continue to work
 +% in math mode, where it is the current \fam that is relevant in most
 +% cases, not the current.  Plain TeX does, for example,
 +% \def\bf{\fam=\bffam \tenbf}  By redefining \tenbf, we obviate the need
 +% to redefine \bf itself.  
 +\def\textfonts{%
 +  \let\tenrm=\textrm \let\tenit=\textit \let\tensl=\textsl
 +  \let\tenbf=\textbf \let\tentt=\texttt \let\smallcaps=\textsc
 +  \let\tensf=\textsf \let\teni=\texti \let\tensy=\textsy
 +  \resetmathfonts}
 +\def\chapfonts{%
 +  \let\tenrm=\chaprm \let\tenit=\chapit \let\tensl=\chapsl 
 +  \let\tenbf=\chapbf \let\tentt=\chaptt \let\smallcaps=\chapsc
 +  \let\tensf=\chapsf \let\teni=\chapi \let\tensy=\chapsy
 +  \resetmathfonts}
 +\def\secfonts{%
 +  \let\tenrm=\secrm \let\tenit=\secit \let\tensl=\secsl
 +  \let\tenbf=\secbf \let\tentt=\sectt \let\smallcaps=\secsc
 +  \let\tensf=\secsf \let\teni=\seci \let\tensy=\secsy
 +  \resetmathfonts}
 +\def\subsecfonts{%
 +  \let\tenrm=\ssecrm \let\tenit=\ssecit \let\tensl=\ssecsl
 +  \let\tenbf=\ssecbf \let\tentt=\ssectt \let\smallcaps=\ssecsc
 +  \let\tensf=\ssecsf \let\teni=\sseci \let\tensy=\ssecsy
 +  \resetmathfonts}
 +\def\indexfonts{%
 +  \let\tenrm=\indrm \let\tenit=\indit \let\tensl=\indsl
 +  \let\tenbf=\indbf \let\tentt=\indtt \let\smallcaps=\indsc
 +  \let\tensf=\indsf \let\teni=\indi \let\tensy=\indsy
 +  \resetmathfonts}
 +
 +% Set up the default fonts, so we can use them for creating boxes.
 +% 
 +\textfonts
 +
 +% Count depth in font-changes, for error checks
 +\newcount\fontdepth \fontdepth=0
 +
 +% Fonts for short table of contents.
 +\font\shortcontrm=cmr12
 +\font\shortcontbf=cmbx12
 +\font\shortcontsl=cmsl12
 +
 +%% Add scribe-like font environments, plus @l for inline lisp (usually sans
 +%% serif) and @ii for TeX italic
 +
 +% \smartitalic{ARG} outputs arg in italics, followed by an italic correction
 +% unless the following character is such as not to need one.
 +\def\smartitalicx{\ifx\next,\else\ifx\next-\else\ifx\next.\else\/\fi\fi\fi}
 +\def\smartitalic#1{{\sl #1}\futurelet\next\smartitalicx}
 +
 +\let\i=\smartitalic
 +\let\var=\smartitalic
 +\let\dfn=\smartitalic
 +\let\emph=\smartitalic
 +\let\cite=\smartitalic
 +
 +\def\b#1{{\bf #1}}
 +\let\strong=\b
 +
 +\def\t#1{{\tt \exhyphenpenalty=10000\rawbackslash \frenchspacing #1}\null}
 +\let\ttfont = \t
 +%\def\samp #1{`{\tt \rawbackslash \frenchspacing #1}'\null}
 +\def\samp #1{`\tclose{#1}'\null}
 +\def\key #1{{\tt \exhyphenpenalty=10000\uppercase{#1}}\null}
 +\def\ctrl #1{{\tt \rawbackslash \hat}#1}
 +
 +\let\file=\samp
 +
 +% @code is a modification of @t,
 +% which makes spaces the same size as normal in the surrounding text.
 +\newdimen\tclosesave
 +\newdimen\tcloserm
 +\def\tclose#1{{\rm \tcloserm=\fontdimen2\font \tt \tclosesave=\fontdimen2\font
 +\fontdimen2\font=\tcloserm
 +% prevent breaking lines at hyphens.
 +\exhyphenpenalty=10000
 +\def\ {{\fontdimen2\font=\tclosesave{} }}%
 + \rawbackslash \frenchspacing #1\fontdimen2\font=\tclosesave}\null}
 +\let\code=\tclose
 +%\let\exp=\tclose  %Was temporary
 +
 +% @kbd is like @code, except that if the argument is just one @key command, 
 +% then @kbd has no effect.
 +
 +\def\xkey{\key}
 +\def\kbdfoo#1#2#3\par{\def\one{#1}\def\three{#3}\def\threex{??}%
 +\ifx\one\xkey\ifx\threex\three \key{#2}%
 +\else\tclose{\look}\fi
 +\else\tclose{\look}\fi}
 +
 +% Typeset a dimension, e.g., `in' or `pt'.  The only reason for the
 +% argument is to make the input look right: @dmn{pt} instead of
 +% @dmn{}pt.
 +% 
 +\def\dmn#1{\thinspace #1}
 +
 +\def\kbd#1{\def\look{#1}\expandafter\kbdfoo\look??\par}
 +
 +\def\l#1{{\li #1}\null}		% 
 +
 +\def\r#1{{\rm #1}}		% roman font
 +% Use of \lowercase was suggested.
 +\def\sc#1{{\smallcaps#1}}	% smallcaps font
 +\def\ii#1{{\it #1}}		% italic font
 +
 +\message{page headings,}
 +
 +\newskip\titlepagetopglue \titlepagetopglue = 1.5in
 +\newskip\titlepagebottomglue \titlepagebottomglue = 2pc
 +
 +% First the title page.  Must do @settitle before @titlepage.
 +\def\titlefont#1{{\titlerm #1}}
 +
 +\newtoks\realeverypar
 +\newif\ifseenauthor
 +\newif\iffinishedtitlepage
 +
 +\def\titlepage{\begingroup \parindent=0pt \textfonts
 +   \let\subtitlerm=\tenrm
 +% I deinstalled the following change because \cmr12 is undefined.
 +% This change was not in the ChangeLog anyway.  --rms.
 +%   \let\subtitlerm=\cmr12
 +   \def\subtitlefont{\subtitlerm \normalbaselineskip = 13pt \normalbaselines}%
 +   %
 +   \def\authorfont{\authorrm \normalbaselineskip = 16pt \normalbaselines}%
 +   %
 +   % Leave some space at the very top of the page.
 +   \vglue\titlepagetopglue
 +   %
 +   % Now you can print the title using @title.
 +   \def\title{\parsearg\titlezzz}%
 +   \def\titlezzz##1{\leftline{\titlefont{##1}}
 +		    % print a rule at the page bottom also.
 +		    \finishedtitlepagefalse
 +		    \vskip4pt \hrule height 4pt \vskip4pt}%
 +   % No rule at page bottom unless we print one at the top with @title.
 +   \finishedtitlepagetrue
 +   %
 +   % Now you can put text using @subtitle.
 +   \def\subtitle{\parsearg\subtitlezzz}%
 +   \def\subtitlezzz##1{{\subtitlefont \rightline{##1}}}%
 +   %
 +   % @author should come last, but may come many times.
 +   \def\author{\parsearg\authorzzz}%
 +   \def\authorzzz##1{\ifseenauthor\else\vskip 0pt plus 1filll\seenauthortrue\fi
 +      {\authorfont \leftline{##1}}}%
 +   %  
 +   % Most title ``pages'' are actually two pages long, with space
 +   % at the top of the second.  We don't want the ragged left on the second.
 +   \let\oldpage = \page
 +   \def\page{%
 +      \iffinishedtitlepage\else
 +	 \finishtitlepage
 +      \fi
 +      \oldpage
 +      \let\page = \oldpage
 +      \hbox{}}%
 +%   \def\page{\oldpage \hbox{}}
 +}
 +
 +\def\Etitlepage{%
 +   \iffinishedtitlepage\else
 +      \finishtitlepage
 +   \fi
 +   % It is important to do the page break before ending the group,
 +   % because the headline and footline are only empty inside the group.
 +   % If we use the new definition of \page, we always get a blank page
 +   % after the title page, which we certainly don't want.
 +   \oldpage
 +   \endgroup
 +   \HEADINGSon
 +}
 +
 +\def\finishtitlepage{%
 +   \vskip4pt \hrule height 2pt
 +   \vskip\titlepagebottomglue
 +   \finishedtitlepagetrue
 +}
 +
 +%%% Set up page headings and footings.
 +
 +\let\thispage=\folio
 +
 +\newtoks \evenheadline    % Token sequence for heading line of even pages
 +\newtoks \oddheadline     % Token sequence for heading line of odd pages
 +\newtoks \evenfootline    % Token sequence for footing line of even pages
 +\newtoks \oddfootline     % Token sequence for footing line of odd pages
 +
 +% Now make Tex use those variables
 +\headline={{\textfonts\rm \ifodd\pageno \the\oddheadline
 +                            \else \the\evenheadline \fi}}
 +\footline={{\textfonts\rm \ifodd\pageno \the\oddfootline
 +                            \else \the\evenfootline \fi}\HEADINGShook}
 +\let\HEADINGShook=\relax
 +
 +% Commands to set those variables.
 +% For example, this is what  @headings on  does
 +% @evenheading @thistitle|@thispage|@thischapter
 +% @oddheading @thischapter|@thispage|@thistitle
 +% @evenfooting @thisfile||
 +% @oddfooting ||@thisfile
 +
 +\def\evenheading{\parsearg\evenheadingxxx}
 +\def\oddheading{\parsearg\oddheadingxxx}
 +\def\everyheading{\parsearg\everyheadingxxx}
 +
 +\def\evenfooting{\parsearg\evenfootingxxx}
 +\def\oddfooting{\parsearg\oddfootingxxx}
 +\def\everyfooting{\parsearg\everyfootingxxx}
 +
 +{\catcode`\@=0 %
 +
 +\gdef\evenheadingxxx #1{\evenheadingyyy #1@|@|@|@|\finish}
 +\gdef\evenheadingyyy #1@|#2@|#3@|#4\finish{%
 +\global\evenheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}}
 +
 +\gdef\oddheadingxxx #1{\oddheadingyyy #1@|@|@|@|\finish}
 +\gdef\oddheadingyyy #1@|#2@|#3@|#4\finish{%
 +\global\oddheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}}
 +
 +\gdef\everyheadingxxx #1{\everyheadingyyy #1@|@|@|@|\finish}
 +\gdef\everyheadingyyy #1@|#2@|#3@|#4\finish{%
 +\global\evenheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}
 +\global\oddheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}}
 +
 +\gdef\evenfootingxxx #1{\evenfootingyyy #1@|@|@|@|\finish}
 +\gdef\evenfootingyyy #1@|#2@|#3@|#4\finish{%
 +\global\evenfootline={\rlap{\centerline{#2}}\line{#1\hfil#3}}}
 +
 +\gdef\oddfootingxxx #1{\oddfootingyyy #1@|@|@|@|\finish}
 +\gdef\oddfootingyyy #1@|#2@|#3@|#4\finish{%
 +\global\oddfootline={\rlap{\centerline{#2}}\line{#1\hfil#3}}}
 +
 +\gdef\everyfootingxxx #1{\everyfootingyyy #1@|@|@|@|\finish}
 +\gdef\everyfootingyyy #1@|#2@|#3@|#4\finish{%
 +\global\evenfootline={\rlap{\centerline{#2}}\line{#1\hfil#3}}
 +\global\oddfootline={\rlap{\centerline{#2}}\line{#1\hfil#3}}}
 +%
 +}% unbind the catcode of @.
 +
 +% @headings double	turns headings on for double-sided printing.
 +% @headings single	turns headings on for single-sided printing.
 +% @headings off		turns them off.
 +% @headings on		same as @headings double, retained for compatibility.
 +% @headings after	turns on double-sided headings after this page.
 +% @headings doubleafter	turns on double-sided headings after this page.
 +% @headings singleafter turns on single-sided headings after this page.
 +% By default, they are off.
 +
 +\def\headings #1 {\csname HEADINGS#1\endcsname}
 +
 +\def\HEADINGSoff{
 +\global\evenheadline={\hfil} \global\evenfootline={\hfil}
 +\global\oddheadline={\hfil} \global\oddfootline={\hfil}}
 +\HEADINGSoff
 +% When we turn headings on, set the page number to 1.
 +% For double-sided printing, put current file name in lower left corner,
 +% chapter name on inside top of right hand pages, document
 +% title on inside top of left hand pages, and page numbers on outside top
 +% edge of all pages.
 +\def\HEADINGSdouble{
 +%\pagealignmacro
 +\global\pageno=1
 +\global\evenfootline={\hfil}
 +\global\oddfootline={\hfil}
 +\global\evenheadline={\line{\folio\hfil\thistitle}}
 +\global\oddheadline={\line{\thischapter\hfil\folio}}
 +}
 +% For single-sided printing, chapter title goes across top left of page,
 +% page number on top right.
 +\def\HEADINGSsingle{
 +%\pagealignmacro
 +\global\pageno=1
 +\global\evenfootline={\hfil}
 +\global\oddfootline={\hfil}
 +\global\evenheadline={\line{\thischapter\hfil\folio}}
 +\global\oddheadline={\line{\thischapter\hfil\folio}}
 +}
 +\def\HEADINGSon{\HEADINGSdouble}
 +
 +\def\HEADINGSafter{\let\HEADINGShook=\HEADINGSdoublex}
 +\let\HEADINGSdoubleafter=\HEADINGSafter
 +\def\HEADINGSdoublex{%
 +\global\evenfootline={\hfil}
 +\global\oddfootline={\hfil}
 +\global\evenheadline={\line{\folio\hfil\thistitle}}
 +\global\oddheadline={\line{\thischapter\hfil\folio}}
 +}
 +
 +\def\HEADINGSsingleafter{\let\HEADINGShook=\HEADINGSsinglex}
 +\def\HEADINGSsinglex{%
 +\global\evenfootline={\hfil}
 +\global\oddfootline={\hfil}
 +\global\evenheadline={\line{\thischapter\hfil\folio}}
 +\global\oddheadline={\line{\thischapter\hfil\folio}}
 +}
 +
 +% Subroutines used in generating headings
 +% Produces Day Month Year style of output.
 +\def\today{\number\day\space
 +\ifcase\month\or
 +January\or February\or March\or April\or May\or June\or
 +July\or August\or September\or October\or November\or December\fi
 +\space\number\year}
 +
 +% Use this if you want the Month Day, Year style of output.
 +%\def\today{\ifcase\month\or
 +%January\or February\or March\or April\or May\or June\or
 +%July\or August\or September\or October\or November\or December\fi
 +%\space\number\day, \number\year}
 +
 +% @settitle line...  specifies the title of the document, for headings
 +% It generates no output of its own
 +
 +\def\thistitle{No Title}
 +\def\settitle{\parsearg\settitlezzz}
 +\def\settitlezzz #1{\gdef\thistitle{#1}}
 +
 +\message{tables,}
 +
 +% @tabs -- simple alignment
 +
 +% These don't work.  For one thing, \+ is defined as outer.
 +% So these macros cannot even be defined.
 +
 +%\def\tabs{\parsearg\tabszzz}
 +%\def\tabszzz #1{\settabs\+#1\cr}
 +%\def\tabline{\parsearg\tablinezzz}
 +%\def\tablinezzz #1{\+#1\cr}
 +%\def\&{&}
 +
 +% Tables -- @table, @ftable, @vtable, @item(x), @kitem(x), @xitem(x).
 +
 +% default indentation of table text
 +\newdimen\tableindent \tableindent=.8in
 +% default indentation of @itemize and @enumerate text
 +\newdimen\itemindent  \itemindent=.3in
 +% margin between end of table item and start of table text.
 +\newdimen\itemmargin  \itemmargin=.1in
 +
 +% used internally for \itemindent minus \itemmargin
 +\newdimen\itemmax
 +
 +% Note @table, @vtable, and @vtable define @item, @itemx, etc., with
 +% these defs.
 +% They also define \itemindex
 +% to index the item name in whatever manner is desired (perhaps none).
 +
 +\def\internalBitem{\smallbreak \parsearg\itemzzz}
 +\def\internalBitemx{\par \parsearg\itemzzz}
 +
 +\def\internalBxitem "#1"{\def\xitemsubtopix{#1} \smallbreak \parsearg\xitemzzz}
 +\def\internalBxitemx "#1"{\def\xitemsubtopix{#1} \par \parsearg\xitemzzz}
 +
 +\def\internalBkitem{\smallbreak \parsearg\kitemzzz}
 +\def\internalBkitemx{\par \parsearg\kitemzzz}
 +
 +\def\kitemzzz #1{\dosubind {kw}{\code{#1}}{for {\bf \lastfunction}}%
 +                 \itemzzz {#1}}
 +
 +\def\xitemzzz #1{\dosubind {kw}{\code{#1}}{for {\bf \xitemsubtopic}}%
 +                 \itemzzz {#1}}
 +
 +\def\itemzzz #1{\begingroup %
 +  \advance\hsize by -\rightskip
 +  \advance\hsize by -\tableindent
 +  \setbox0=\hbox{\itemfont{#1}}%
 +  \itemindex{#1}%
 +  \nobreak % This prevents a break before @itemx.
 +  %
 +  % Be sure we are not still in the middle of a paragraph.
 +  \parskip=0in
 +  \par
 +  %
 +  % If the item text does not fit in the space we have, put it on a line
 +  % by itself, and do not allow a page break either before or after that
 +  % line.  We do not start a paragraph here because then if the next
 +  % command is, e.g., @kindex, the whatsit would get put into the
 +  % horizontal list on a line by itself, resulting in extra blank space.
 +  \ifdim \wd0>\itemmax
 +    \setbox0=\hbox{\hskip \leftskip \hskip -\tableindent \unhbox0}\box0
 +    \nobreak
 +  \else
 +    % The item text fits into the space.  Start a paragraph, so that the
 +    % following text (if any) will end up on the same line.  Since that
 +    % text will be indented by \tableindent, we make the item text be in
 +    % a zero-width box.
 +    \noindent
 +    \rlap{\hskip -\tableindent\box0}%
 +  \fi
 +  \endgroup
 +}
 +
 +\def\item{\errmessage{@item while not in a table}}
 +\def\itemx{\errmessage{@itemx while not in a table}}
 +\def\kitem{\errmessage{@kitem while not in a table}}
 +\def\kitemx{\errmessage{@kitemx while not in a table}}
 +\def\xitem{\errmessage{@xitem while not in a table}}
 +\def\xitemx{\errmessage{@xitemx while not in a table}}
 +
 +%% Contains a kludge to get @end[description] to work
 +\def\description{\tablez{\dontindex}{1}{}{}{}{}}
 +
 +\def\table{\begingroup\inENV\obeylines\obeyspaces\tablex}
 +{\obeylines\obeyspaces%
 +\gdef\tablex #1^^M{%
 +\tabley\dontindex#1        \endtabley}}
 +
 +\def\ftable{\begingroup\inENV\obeylines\obeyspaces\ftablex}
 +{\obeylines\obeyspaces%
 +\gdef\ftablex #1^^M{%
 +\tabley\fnitemindex#1        \endtabley
 +\def\Eftable{\endgraf\endgroup\afterenvbreak}%
 +\let\Etable=\relax}}
 +
 +\def\vtable{\begingroup\inENV\obeylines\obeyspaces\vtablex}
 +{\obeylines\obeyspaces%
 +\gdef\vtablex #1^^M{%
 +\tabley\vritemindex#1        \endtabley
 +\def\Evtable{\endgraf\endgroup\afterenvbreak}%
 +\let\Etable=\relax}}
 +
 +\def\dontindex #1{}
 +\def\fnitemindex #1{\doind {fn}{\code{#1}}}%
 +\def\vritemindex #1{\doind {vr}{\code{#1}}}%
 +
 +{\obeyspaces %
 +\gdef\tabley#1#2 #3 #4 #5 #6 #7\endtabley{\endgroup%
 +\tablez{#1}{#2}{#3}{#4}{#5}{#6}}}
 +
 +\def\tablez #1#2#3#4#5#6{%
 +\aboveenvbreak %
 +\begingroup %
 +\def\Edescription{\Etable}% Neccessary kludge.
 +\let\itemindex=#1%
 +\ifnum 0#3>0 \advance \leftskip by #3\mil \fi %
 +\ifnum 0#4>0 \tableindent=#4\mil \fi %
 +\ifnum 0#5>0 \advance \rightskip by #5\mil \fi %
 +\def\itemfont{#2}%
 +\itemmax=\tableindent %
 +\advance \itemmax by -\itemmargin %
 +\advance \leftskip by \tableindent %
 +\exdentamount=\tableindent
 +\parindent = 0pt
 +\parskip = \smallskipamount
 +\ifdim \parskip=0pt \parskip=2pt \fi%
 +\def\Etable{\endgraf\endgroup\afterenvbreak}%
 +\let\item = \internalBitem %
 +\let\itemx = \internalBitemx %
 +\let\kitem = \internalBkitem %
 +\let\kitemx = \internalBkitemx %
 +\let\xitem = \internalBxitem %
 +\let\xitemx = \internalBxitemx %
 +}
 +
 +% This is the counter used by @enumerate, which is really @itemize
 +
 +\newcount \itemno
 +
 +\def\itemize{\parsearg\itemizezzz}
 +
 +\def\itemizezzz #1{%
 +  \begingroup % ended by the @end itemsize
 +  \itemizey {#1}{\Eitemize}
 +}
 +
 +\def\itemizey #1#2{%
 +\aboveenvbreak %
 +\itemmax=\itemindent %
 +\advance \itemmax by -\itemmargin %
 +\advance \leftskip by \itemindent %
 +\exdentamount=\itemindent
 +\parindent = 0pt %
 +\parskip = \smallskipamount %
 +\ifdim \parskip=0pt \parskip=2pt \fi%
 +\def#2{\endgraf\endgroup\afterenvbreak}%
 +\def\itemcontents{#1}%
 +\let\item=\itemizeitem}
 +
 +\def\bullet{$\ptexbullet$}
 +\def\minus{$-$}
 +
 +% Set sfcode to normal for the chars that usually have another value.
 +% These are `.?!:;,'
 +\def\frenchspacing{\sfcode46=1000 \sfcode63=1000 \sfcode33=1000
 +  \sfcode58=1000 \sfcode59=1000 \sfcode44=1000 }
 +
 +% \splitoff TOKENS\endmark defines \first to be the first token in
 +% TOKENS, and \rest to be the remainder.
 +% 
 +\def\splitoff#1#2\endmark{\def\first{#1}\def\rest{#2}}%
 +
 +% Allow an optional argument of an uppercase letter, lowercase letter,
 +% or number, to specify the first label in the enumerated list.  No
 +% argument is the same as `1'.
 +% 
 +\def\enumerate{\parsearg\enumeratezzz}
 +\def\enumeratezzz #1{\enumeratey #1  \endenumeratey}
 +\def\enumeratey #1 #2\endenumeratey{%
 +  \begingroup % ended by the @end enumerate
 +  %
 +  % If we were given no argument, pretend we were given `1'.
 +  \def\thearg{#1}%
 +  \ifx\thearg\empty \def\thearg{1}\fi
 +  %
 +  % Detect if the argument is a single token.  If so, it might be a
 +  % letter.  Otherwise, the only valid thing it can be is a number.
 +  % (We will always have one token, because of the test we just made.
 +  % This is a good thing, since \splitoff doesn't work given nothing at
 +  % all -- the first parameter is undelimited.)
 +  \expandafter\splitoff\thearg\endmark
 +  \ifx\rest\empty
 +    % Only one token in the argument.  It could still be anything.
 +    % A ``lowercase letter'' is one whose \lccode is nonzero.
 +    % An ``uppercase letter'' is one whose \lccode is both nonzero, and
 +    %   not equal to itself.
 +    % Otherwise, we assume it's a number.
 +    % 
 +    % We need the \relax at the end of the \ifnum lines to stop TeX from
 +    % continuing to look for a <number>.
 +    % 
 +    \ifnum\lccode\expandafter`\thearg=0\relax 
 +      \numericenumerate % a number (we hope)
 +    \else
 +      % It's a letter.
 +      \ifnum\lccode\expandafter`\thearg=\expandafter`\thearg\relax
 +        \lowercaseenumerate % lowercase letter
 +      \else
 +        \uppercaseenumerate % uppercase letter
 +      \fi
 +    \fi
 +  \else
 +    % Multiple tokens in the argument.  We hope it's a number.
 +    \numericenumerate
 +  \fi
 +}
 +
 +% An @enumerate whose labels are integers.  The starting integer is
 +% given in \thearg.
 +% 
 +\def\numericenumerate{%
 +  \itemno = \thearg
 +  \startenumeration{\the\itemno}%
 +}
 +
 +% The starting (lowercase) letter is in \thearg.
 +\def\lowercaseenumerate{%
 +  \itemno = \expandafter`\thearg
 +  \startenumeration{%
 +    % Be sure we're not beyond the end of the alphabet.
 +    \ifnum\itemno=0
 +      \errmessage{No more lowercase letters in @enumerate; get a bigger
 +                  alphabet}%
 +    \fi
 +    \char\lccode\itemno
 +  }%
 +}
 +
 +% The starting (uppercase) letter is in \thearg.
 +\def\uppercaseenumerate{%
 +  \itemno = \expandafter`\thearg
 +  \startenumeration{%
 +    % Be sure we're not beyond the end of the alphabet.
 +    \ifnum\itemno=0
 +      \errmessage{No more uppercase letters in @enumerate; get a bigger
 +                  alphabet}
 +    \fi
 +    \char\uccode\itemno
 +  }%
 +}
 +
 +% Call itemizey, adding a period to the first argument and supplying the
 +% common last two arguments.  Also subtract one from the initial value in
 +% \itemno, since @item increments \itemno.
 +% 
 +\def\startenumeration#1{%
 +  \advance\itemno by -1
 +  \itemizey{#1.}\Eenumerate\flushcr
 +}
 +
 +% @alphaenumerate and @capsenumerate are abbreviations for giving an arg
 +% to @enumerate.
 +% 
 +\def\alphaenumerate{\enumerate{a}}
 +\def\capsenumerate{\enumerate{A}}
 +\def\Ealphaenumerate{\Eenumerate}
 +\def\Ecapsenumerate{\Eenumerate}
 +
 +% Definition of @item while inside @itemize.
 +
 +\def\itemizeitem{%
 +\advance\itemno by 1
 +{\let\par=\endgraf \smallbreak}%
 +\ifhmode \errmessage{\in hmode at itemizeitem}\fi
 +{\parskip=0in \hskip 0pt
 +\hbox to 0pt{\hss \itemcontents\hskip \itemmargin}%
 +\vadjust{\penalty 1200}}%
 +\flushcr}
 +
 +\message{indexing,}
 +% Index generation facilities
 +
 +% Define \newwrite to be identical to plain tex's \newwrite
 +% except not \outer, so it can be used within \newindex.
 +{\catcode`\@=11
 +\gdef\newwrite{\alloc@7\write\chardef\sixt@@n}}
 +
 +% \newindex {foo} defines an index named foo.
 +% It automatically defines \fooindex such that
 +% \fooindex ...rest of line... puts an entry in the index foo.
 +% It also defines \fooindfile to be the number of the output channel for
 +% the file that	accumulates this index.  The file's extension is foo.
 +% The name of an index should be no more than 2 characters long
 +% for the sake of vms.
 +
 +\def\newindex #1{
 +\expandafter\newwrite \csname#1indfile\endcsname% Define number for output file
 +\openout \csname#1indfile\endcsname \jobname.#1	% Open the file
 +\expandafter\xdef\csname#1index\endcsname{%	% Define \xxxindex
 +\noexpand\doindex {#1}}
 +}
 +
 +% @defindex foo  ==  \newindex{foo}
 +
 +\def\defindex{\parsearg\newindex}
 +
 +% Define @defcodeindex, like @defindex except put all entries in @code.
 +
 +\def\newcodeindex #1{
 +\expandafter\newwrite \csname#1indfile\endcsname% Define number for output file
 +\openout \csname#1indfile\endcsname \jobname.#1	% Open the file
 +\expandafter\xdef\csname#1index\endcsname{%	% Define \xxxindex
 +\noexpand\docodeindex {#1}}
 +}
 +
 +\def\defcodeindex{\parsearg\newcodeindex}
 +
 +% @synindex foo bar    makes index foo feed into index bar.
 +% Do this instead of @defindex foo if you don't want it as a separate index.
 +\def\synindex #1 #2 {%
 +\expandafter\let\expandafter\synindexfoo\expandafter=\csname#2indfile\endcsname
 +\expandafter\let\csname#1indfile\endcsname=\synindexfoo
 +\expandafter\xdef\csname#1index\endcsname{%	% Define \xxxindex
 +\noexpand\doindex {#2}}%
 +}
 +
 +% @syncodeindex foo bar   similar, but put all entries made for index foo
 +% inside @code.
 +\def\syncodeindex #1 #2 {%
 +\expandafter\let\expandafter\synindexfoo\expandafter=\csname#2indfile\endcsname
 +\expandafter\let\csname#1indfile\endcsname=\synindexfoo
 +\expandafter\xdef\csname#1index\endcsname{%	% Define \xxxindex
 +\noexpand\docodeindex {#2}}%
 +}
 +
 +% Define \doindex, the driver for all \fooindex macros.
 +% Argument #1 is generated by the calling \fooindex macro,
 +%  and it is "foo", the name of the index.
 +
 +% \doindex just uses \parsearg; it calls \doind for the actual work.
 +% This is because \doind is more useful to call from other macros.
 +
 +% There is also \dosubind {index}{topic}{subtopic}
 +% which makes an entry in a two-level index such as the operation index.
 +
 +\def\doindex#1{\edef\indexname{#1}\parsearg\singleindexer}
 +\def\singleindexer #1{\doind{\indexname}{#1}}
 +
 +% like the previous two, but they put @code around the argument.
 +\def\docodeindex#1{\edef\indexname{#1}\parsearg\singlecodeindexer}
 +\def\singlecodeindexer #1{\doind{\indexname}{\code{#1}}}
 +
 +\def\indexdummies{%
 +\def\_{{\realbackslash _}}%
 +\def\w{\realbackslash w }%
 +\def\bf{\realbackslash bf }%
 +\def\rm{\realbackslash rm }%
 +\def\sl{\realbackslash sl }%
 +\def\sf{\realbackslash sf}%
 +\def\tt{\realbackslash tt}%
 +\def\gtr{\realbackslash gtr}%
 +\def\less{\realbackslash less}%
 +\def\hat{\realbackslash hat}%
 +\def\char{\realbackslash char}%
 +\def\TeX{\realbackslash TeX}%
 +\def\dots{\realbackslash dots }%
 +\def\copyright{\realbackslash copyright }%
 +\def\tclose##1{\realbackslash tclose {##1}}%
 +\def\code##1{\realbackslash code {##1}}%
 +\def\samp##1{\realbackslash samp {##1}}%
 +\def\t##1{\realbackslash r {##1}}%
 +\def\r##1{\realbackslash r {##1}}%
 +\def\i##1{\realbackslash i {##1}}%
 +\def\b##1{\realbackslash b {##1}}%
 +\def\cite##1{\realbackslash cite {##1}}%
 +\def\key##1{\realbackslash key {##1}}%
 +\def\file##1{\realbackslash file {##1}}%
 +\def\var##1{\realbackslash var {##1}}%
 +\def\kbd##1{\realbackslash kbd {##1}}%
 +}
 +
 +% \indexnofonts no-ops all font-change commands.
 +% This is used when outputting the strings to sort the index by.
 +\def\indexdummyfont#1{#1}
 +\def\indexdummytex{TeX}
 +\def\indexdummydots{...}
 +
 +\def\indexnofonts{%
 +\let\w=\indexdummyfont
 +\let\t=\indexdummyfont
 +\let\r=\indexdummyfont
 +\let\i=\indexdummyfont
 +\let\b=\indexdummyfont
 +\let\emph=\indexdummyfont
 +\let\strong=\indexdummyfont
 +\let\cite=\indexdummyfont
 +\let\sc=\indexdummyfont
 +%Don't no-op \tt, since it isn't a user-level command
 +% and is used in the definitions of the active chars like <, >, |...
 +%\let\tt=\indexdummyfont
 +\let\tclose=\indexdummyfont
 +\let\code=\indexdummyfont
 +\let\file=\indexdummyfont
 +\let\samp=\indexdummyfont
 +\let\kbd=\indexdummyfont
 +\let\key=\indexdummyfont
 +\let\var=\indexdummyfont
 +\let\TeX=\indexdummytex
 +\let\dots=\indexdummydots
 +}
 +
 +% To define \realbackslash, we must make \ not be an escape.
 +% We must first make another character (@) an escape
 +% so we do not become unable to do a definition.
 +
 +{\catcode`\@=0 \catcode`\\=\other
 +@gdef@realbackslash{\}}
 +
 +\let\indexbackslash=0  %overridden during \printindex.
 +
 +\def\doind #1#2{%
 +{\count10=\lastpenalty %
 +{\indexdummies % Must do this here, since \bf, etc expand at this stage
 +\escapechar=`\\%
 +{\let\folio=0% Expand all macros now EXCEPT \folio
 +\def\rawbackslashxx{\indexbackslash}% \indexbackslash isn't defined now
 +% so it will be output as is; and it will print as backslash in the indx.
 +%
 +% Now process the index-string once, with all font commands turned off,
 +% to get the string to sort the index by.
 +{\indexnofonts
 +\xdef\temp1{#2}%
 +}%
 +% Now produce the complete index entry.  We process the index-string again,
 +% this time with font commands expanded, to get what to print in the index.
 +\edef\temp{%
 +\write \csname#1indfile\endcsname{%
 +\realbackslash entry {\temp1}{\folio}{#2}}}%
 +\temp }%
 +}\penalty\count10}}
 +
 +\def\dosubind #1#2#3{%
 +{\count10=\lastpenalty %
 +{\indexdummies % Must do this here, since \bf, etc expand at this stage
 +\escapechar=`\\%
 +{\let\folio=0%
 +\def\rawbackslashxx{\indexbackslash}%
 +%
 +% Now process the index-string once, with all font commands turned off,
 +% to get the string to sort the index by.
 +{\indexnofonts
 +\xdef\temp1{#2 #3}%
 +}%
 +% Now produce the complete index entry.  We process the index-string again,
 +% this time with font commands expanded, to get what to print in the index.
 +\edef\temp{%
 +\write \csname#1indfile\endcsname{%
 +\realbackslash entry {\temp1}{\folio}{#2}{#3}}}%
 +\temp }%
 +}\penalty\count10}}
 +
 +% The index entry written in the file actually looks like
 +%  \entry {sortstring}{page}{topic}
 +% or
 +%  \entry {sortstring}{page}{topic}{subtopic}
 +% The texindex program reads in these files and writes files
 +% containing these kinds of lines:
 +%  \initial {c}
 +%     before the first topic whose initial is c
 +%  \entry {topic}{pagelist}
 +%     for a topic that is used without subtopics
 +%  \primary {topic}
 +%     for the beginning of a topic that is used with subtopics
 +%  \secondary {subtopic}{pagelist}
 +%     for each subtopic.
 +
 +% Define the user-accessible indexing commands 
 +% @findex, @vindex, @kindex, @cindex.
 +
 +\def\findex {\fnindex}
 +\def\kindex {\kyindex}
 +\def\cindex {\cpindex}
 +\def\vindex {\vrindex}
 +\def\tindex {\tpindex}
 +\def\pindex {\pgindex}
 +
 +\def\cindexsub {\begingroup\obeylines\cindexsub}
 +{\obeylines %
 +\gdef\cindexsub "#1" #2^^M{\endgroup %
 +\dosubind{cp}{#2}{#1}}}
 +
 +% Define the macros used in formatting output of the sorted index material.
 +
 +% This is what you call to cause a particular index to get printed.
 +% Write
 +% @unnumbered Function Index
 +% @printindex fn
 +
 +\def\printindex{\parsearg\doprintindex}
 +
 +\def\doprintindex#1{%
 +  \tex
 +  \dobreak \chapheadingskip {10000}
 +  \catcode`\%=\other\catcode`\&=\other\catcode`\#=\other
 +  \catcode`\$=\other\catcode`\_=\other
 +  \catcode`\~=\other
 +  %
 +  % The following don't help, since the chars were translated
 +  % when the raw index was written, and their fonts were discarded
 +  % due to \indexnofonts.
 +  %\catcode`\"=\active
 +  %\catcode`\^=\active
 +  %\catcode`\_=\active
 +  %\catcode`\|=\active
 +  %\catcode`\<=\active
 +  %\catcode`\>=\active
 +  % %
 +  \def\indexbackslash{\rawbackslashxx}
 +  \indexfonts\rm \tolerance=9500 \advance\baselineskip -1pt
 +  \begindoublecolumns
 +  %
 +  % See if the index file exists and is nonempty.
 +  \openin 1 \jobname.#1s
 +  \ifeof 1 
 +    % \enddoublecolumns gets confused if there is no text in the index,
 +    % and it loses the chapter title and the aux file entries for the
 +    % index.  The easiest way to prevent this problem is to make sure
 +    % there is some text.
 +    (Index is nonexistent)
 +    \else
 +    %
 +    % If the index file exists but is empty, then \openin leaves \ifeof
 +    % false.  We have to make TeX try to read something from the file, so
 +    % it can discover if there is anything in it.
 +    \read 1 to \temp
 +    \ifeof 1
 +      (Index is empty)
 +    \else
 +      \input \jobname.#1s
 +    \fi
 +  \fi
 +  \closein 1
 +  \enddoublecolumns
 +  \Etex
 +}
 +
 +% These macros are used by the sorted index file itself.
 +% Change them to control the appearance of the index.
 +
 +% Same as \bigskipamount except no shrink.
 +% \balancecolumns gets confused if there is any shrink.
 +\newskip\initialskipamount \initialskipamount 12pt plus4pt
 +
 +\def\initial #1{%
 +{\let\tentt=\sectt \let\tt=\sectt \let\sf=\sectt
 +\ifdim\lastskip<\initialskipamount
 +\removelastskip \penalty-200 \vskip \initialskipamount\fi
 +\line{\secbf#1\hfill}\kern 2pt\penalty10000}}
 +
 +\def\entry #1#2{\begingroup
 +  \parfillskip=0in \parskip=0in \parindent=0in
 +  %
 +  % \hangindent is only relevant when the page number and the entry text
 +  % don't fit on one line.  In that case, bob suggests starting the dots
 +  % pretty far over on the line.
 +  % \hangafter is reset to 1 at the start of each paragraph.
 +  \hangindent=.75\hsize
 +  \noindent
 +  %
 +  % Don't break the text of the index entry.
 +  \hbox{#1}%
 +  %
 +  % If we must, put the page number on a line of its own, and fill out
 +  % this line with blank space.  (The \hfil is overwhelmed with the
 +  % fill leaders glue in \indexdotfill if the page number does fit.)
 +  \hfil\penalty50
 +  \null\nobreak\indexdotfill % Have leaders before the page number.
 +  %
 +  % The `\ ' here is removed by the implicit \unskip that TeX does as
 +  % part of (the primitive) \par.  Without, a spurious underfull \hbox ensues.
 +  \ #2% The page number ends the paragraph.
 +  \par
 +\endgroup}
 +
 +% Like \dotfill except takes at least 1 em.
 +\def\indexdotfill{\cleaders
 +  \hbox{$\mathsurround=0pt \mkern1.5mu . \mkern1.5mu$}\hskip 1em plus 1fill}
 +
 +\def\primary #1{\line{#1\hfil}}
 +
 +\newskip\secondaryindent \secondaryindent=0.5cm
 +
 +\def\secondary #1#2{
 +{\parfillskip=0in \parskip=0in
 +\hangindent =1in \hangafter=1
 +\noindent\hskip\secondaryindent\hbox{#1}\indexdotfill #2\par
 +}}
 +
 +%% Define two-column mode, which is used in indexes.
 +%% Adapted from the TeXBook, page 416
 +\catcode `\@=11
 +
 +\newbox\partialpage
 +
 +\newdimen\doublecolumnhsize  \doublecolumnhsize = 3.11in
 +\newdimen\doublecolumnvsize  \doublecolumnvsize = 19.1in
 +\newdimen\availdimen@
 +
 +\def\begindoublecolumns{\begingroup
 +  \output={\global\setbox\partialpage=
 +    \vbox{\unvbox255\kern -\topskip \kern \baselineskip}}\eject
 +  \output={\doublecolumnout}%
 +  \hsize=\doublecolumnhsize \vsize=\doublecolumnvsize}
 +\def\enddoublecolumns{\output={\balancecolumns}\eject
 +  \endgroup \pagegoal=\vsize}
 +
 +\def\doublecolumnout{\splittopskip=\topskip \splitmaxdepth=\maxdepth
 +  \dimen@=\pageheight \advance\dimen@ by-\ht\partialpage
 +  \setbox0=\vsplit255 to\dimen@ \setbox2=\vsplit255 to\dimen@
 +  \onepageout\pagesofar \unvbox255 \penalty\outputpenalty}
 +\def\pagesofar{\unvbox\partialpage %
 +  \hsize=\doublecolumnhsize % have to restore this since output routine
 +%	      changes it to set cropmarks (P. A. MacKay, 12 Nov. 1986)
 +  \wd0=\hsize \wd2=\hsize \hbox to\pagewidth{\box0\hfil\box2}}
 +\def\balancecolumns{%
 +% Unset the glue.
 +  \setbox255=\vbox{\unvbox255}
 +  \dimen@=\ht255
 +  \advance\dimen@ by\topskip \advance\dimen@ by-\baselineskip
 +  \divide\dimen@ by2
 +  \availdimen@=\pageheight \advance\availdimen@ by-\ht\partialpage
 +% If the remaining data is too big for one page,
 +% output one page normally, then work with what remains.
 +  \ifdim \dimen@>\availdimen@
 +   {
 +     \splittopskip=\topskip \splitmaxdepth=\maxdepth
 +     \dimen@=\pageheight \advance\dimen@ by-\ht\partialpage
 +     \setbox0=\vsplit255 to\dimen@ \setbox2=\vsplit255 to\dimen@
 +     \onepageout\pagesofar
 +   }
 +% Recompute size of what remains, in case we just output some of it.
 +  \dimen@=\ht255
 +  \advance\dimen@ by\topskip \advance\dimen@ by-\baselineskip
 +  \divide\dimen@ by2
 +  \fi
 +  \setbox0=\vbox{\unvbox255}
 +  \splittopskip=\topskip
 +  {\vbadness=10000 \loop \global\setbox3=\copy0
 +    \global\setbox1=\vsplit3 to\dimen@
 +    \ifdim\ht3>\dimen@ \global\advance\dimen@ by1pt \repeat}
 +  \setbox0=\vbox to\dimen@{\unvbox1}  \setbox2=\vbox to\dimen@{\unvbox3}
 +  \pagesofar}
 +
 +\catcode `\@=\other
 +\message{sectioning,}
 +% Define chapters, sections, etc.
 +
 +\newcount \chapno
 +\newcount \secno        \secno=0
 +\newcount \subsecno     \subsecno=0
 +\newcount \subsubsecno  \subsubsecno=0
 +
 +% This counter is funny since it counts through charcodes of letters A, B, ...
 +\newcount \appendixno  \appendixno = `\@
 +\def\appendixletter{\char\the\appendixno}
 +
 +\newwrite \contentsfile
 +% This is called from \setfilename.
 +\def\opencontents{\openout \contentsfile = \jobname.toc}
 +
 +% Each @chapter defines this as the name of the chapter.
 +% page headings and footings can use it.  @section does likewise
 +
 +\def\thischapter{} \def\thissection{}
 +\def\seccheck#1{\if \pageno<0 %
 +\errmessage{@#1 not allowed after generating table of contents}\fi
 +%
 +}
 +
 +\def\chapternofonts{%
 +\let\rawbackslash=\relax%
 +\let\frenchspacing=\relax%
 +\def\result{\realbackslash result}
 +\def\equiv{\realbackslash equiv}
 +\def\expansion{\realbackslash expansion}
 +\def\print{\realbackslash print}
 +\def\TeX{\realbackslash TeX}
 +\def\dots{\realbackslash dots}
 +\def\copyright{\realbackslash copyright}
 +\def\tt{\realbackslash tt}
 +\def\bf{\realbackslash bf }
 +\def\w{\realbackslash w}
 +\def\less{\realbackslash less}
 +\def\gtr{\realbackslash gtr}
 +\def\hat{\realbackslash hat}
 +\def\char{\realbackslash char}
 +\def\tclose##1{\realbackslash tclose {##1}}
 +\def\code##1{\realbackslash code {##1}}
 +\def\samp##1{\realbackslash samp {##1}}
 +\def\r##1{\realbackslash r {##1}}
 +\def\b##1{\realbackslash b {##1}}
 +\def\key##1{\realbackslash key {##1}}
 +\def\file##1{\realbackslash file {##1}}
 +\def\kbd##1{\realbackslash kbd {##1}}
 +% These are redefined because @smartitalic wouldn't work inside xdef.
 +\def\i##1{\realbackslash i {##1}}
 +\def\cite##1{\realbackslash cite {##1}}
 +\def\var##1{\realbackslash var {##1}}
 +\def\emph##1{\realbackslash emph {##1}}
 +\def\dfn##1{\realbackslash dfn {##1}}
 +}
 +
 +\def\thischaptername{No Chapter Title}
 +\outer\def\chapter{\parsearg\chapterzzz}
 +\def\chapterzzz #1{\seccheck{chapter}%
 +\secno=0 \subsecno=0 \subsubsecno=0
 +\global\advance \chapno by 1 \message{Chapter \the\chapno}%
 +\chapmacro {#1}{\the\chapno}%
 +\gdef\thissection{#1}%
 +\gdef\thischaptername{#1}%
 +% We don't substitute the actual chapter name into \thischapter
 +% because we don't want its macros evaluated now.
 +\xdef\thischapter{Chapter \the\chapno: \noexpand\thischaptername}%
 +{\chapternofonts%
 +\edef\temp{{\realbackslash chapentry {#1}{\the\chapno}{\noexpand\folio}}}%
 +\escapechar=`\\%
 +\write \contentsfile \temp  %
 +\donoderef %
 +\global\let\section = \numberedsec
 +\global\let\subsection = \numberedsubsec
 +\global\let\subsubsection = \numberedsubsubsec
 +}}
 +
 +\outer\def\appendix{\parsearg\appendixzzz}
 +\def\appendixzzz #1{\seccheck{appendix}%
 +\secno=0 \subsecno=0 \subsubsecno=0
 +\global\advance \appendixno by 1 \message{Appendix \appendixletter}%
 +\chapmacro {#1}{Appendix \appendixletter}%
 +\gdef\thissection{#1}%
 +\gdef\thischaptername{#1}%
 +\xdef\thischapter{Appendix \appendixletter: \noexpand\thischaptername}%
 +{\chapternofonts%
 +\edef\temp{{\realbackslash chapentry 
 +  {#1}{Appendix \appendixletter}{\noexpand\folio}}}%
 +\escapechar=`\\%
 +\write \contentsfile \temp  %
 +\appendixnoderef %
 +\global\let\section = \appendixsec
 +\global\let\subsection = \appendixsubsec
 +\global\let\subsubsection = \appendixsubsubsec
 +}}
 +
 +\outer\def\top{\parsearg\unnumberedzzz}
 +\outer\def\unnumbered{\parsearg\unnumberedzzz}
 +\def\unnumberedzzz #1{\seccheck{unnumbered}%
 +\secno=0 \subsecno=0 \subsubsecno=0 \message{(#1)}
 +\unnumbchapmacro {#1}%
 +\gdef\thischapter{#1}\gdef\thissection{#1}%
 +{\chapternofonts%
 +\edef\temp{{\realbackslash unnumbchapentry {#1}{\noexpand\folio}}}%
 +\escapechar=`\\%
 +\write \contentsfile \temp  %
 +\unnumbnoderef %
 +\global\let\section = \unnumberedsec
 +\global\let\subsection = \unnumberedsubsec
 +\global\let\subsubsection = \unnumberedsubsubsec
 +}}
 +
 +\outer\def\numberedsec{\parsearg\seczzz}
 +\def\seczzz #1{\seccheck{section}%
 +\subsecno=0 \subsubsecno=0 \global\advance \secno by 1 %
 +\gdef\thissection{#1}\secheading {#1}{\the\chapno}{\the\secno}%
 +{\chapternofonts%
 +\edef\temp{{\realbackslash secentry %
 +{#1}{\the\chapno}{\the\secno}{\noexpand\folio}}}%
 +\escapechar=`\\%
 +\write \contentsfile \temp %
 +\donoderef %
 +\penalty 10000 %
 +}}
 +
 +\outer\def\appendixsection{\parsearg\appendixsectionzzz}
 +\outer\def\appendixsec{\parsearg\appendixsectionzzz}
 +\def\appendixsectionzzz #1{\seccheck{appendixsection}%
 +\subsecno=0 \subsubsecno=0 \global\advance \secno by 1 %
 +\gdef\thissection{#1}\secheading {#1}{\appendixletter}{\the\secno}%
 +{\chapternofonts%
 +\edef\temp{{\realbackslash secentry %
 +{#1}{\appendixletter}{\the\secno}{\noexpand\folio}}}%
 +\escapechar=`\\%
 +\write \contentsfile \temp %
 +\appendixnoderef %
 +\penalty 10000 %
 +}}
 +
 +\outer\def\unnumberedsec{\parsearg\unnumberedseczzz}
 +\def\unnumberedseczzz #1{\seccheck{unnumberedsec}%
 +\plainsecheading {#1}\gdef\thissection{#1}%
 +{\chapternofonts%
 +\edef\temp{{\realbackslash unnumbsecentry{#1}{\noexpand\folio}}}%
 +\escapechar=`\\%
 +\write \contentsfile \temp %
 +\unnumbnoderef %
 +\penalty 10000 %
 +}}
 +
 +\outer\def\numberedsubsec{\parsearg\numberedsubseczzz}
 +\def\numberedsubseczzz #1{\seccheck{subsection}%
 +\gdef\thissection{#1}\subsubsecno=0 \global\advance \subsecno by 1 %
 +\subsecheading {#1}{\the\chapno}{\the\secno}{\the\subsecno}%
 +{\chapternofonts%
 +\edef\temp{{\realbackslash subsecentry %
 +{#1}{\the\chapno}{\the\secno}{\the\subsecno}{\noexpand\folio}}}%
 +\escapechar=`\\%
 +\write \contentsfile \temp %
 +\donoderef %
 +\penalty 10000 %
 +}}
 +
 +\outer\def\appendixsubsec{\parsearg\appendixsubseczzz}
 +\def\appendixsubseczzz #1{\seccheck{appendixsubsec}%
 +\gdef\thissection{#1}\subsubsecno=0 \global\advance \subsecno by 1 %
 +\subsecheading {#1}{\appendixletter}{\the\secno}{\the\subsecno}%
 +{\chapternofonts%
 +\edef\temp{{\realbackslash subsecentry %
 +{#1}{\appendixletter}{\the\secno}{\the\subsecno}{\noexpand\folio}}}%
 +\escapechar=`\\%
 +\write \contentsfile \temp %
 +\appendixnoderef %
 +\penalty 10000 %
 +}}
 +
 +\outer\def\unnumberedsubsec{\parsearg\unnumberedsubseczzz}
 +\def\unnumberedsubseczzz #1{\seccheck{unnumberedsubsec}%
 +\plainsecheading {#1}\gdef\thissection{#1}%
 +{\chapternofonts%
 +\edef\temp{{\realbackslash unnumbsubsecentry{#1}{\noexpand\folio}}}%
 +\escapechar=`\\%
 +\write \contentsfile \temp %
 +\unnumbnoderef %
 +\penalty 10000 %
 +}}
 +
 +\outer\def\numberedsubsubsec{\parsearg\numberedsubsubseczzz}
 +\def\numberedsubsubseczzz #1{\seccheck{subsubsection}%
 +\gdef\thissection{#1}\global\advance \subsubsecno by 1 %
 +\subsubsecheading {#1}
 +  {\the\chapno}{\the\secno}{\the\subsecno}{\the\subsubsecno}%
 +{\chapternofonts%
 +\edef\temp{{\realbackslash subsubsecentry %
 +  {#1}
 +  {\the\chapno}{\the\secno}{\the\subsecno}{\the\subsubsecno}
 +  {\noexpand\folio}}}%
 +\escapechar=`\\%
 +\write \contentsfile \temp %
 +\donoderef %
 +\penalty 10000 %
 +}}
 +
 +\outer\def\appendixsubsubsec{\parsearg\appendixsubsubseczzz}
 +\def\appendixsubsubseczzz #1{\seccheck{appendixsubsubsec}%
 +\gdef\thissection{#1}\global\advance \subsubsecno by 1 %
 +\subsubsecheading {#1}
 +  {\appendixletter}{\the\secno}{\the\subsecno}{\the\subsubsecno}%
 +{\chapternofonts%
 +\edef\temp{{\realbackslash subsubsecentry{#1}%
 +  {\appendixletter}
 +  {\the\secno}{\the\subsecno}{\the\subsubsecno}{\noexpand\folio}}}%
 +\escapechar=`\\%
 +\write \contentsfile \temp %
 +\appendixnoderef %
 +\penalty 10000 %
 +}}
 +
 +\outer\def\unnumberedsubsubsec{\parsearg\unnumberedsubsubseczzz}
 +\def\unnumberedsubsubseczzz #1{\seccheck{unnumberedsubsubsec}%
 +\plainsecheading {#1}\gdef\thissection{#1}%
 +{\chapternofonts%
 +\edef\temp{{\realbackslash unnumbsubsubsecentry{#1}{\noexpand\folio}}}%
 +\escapechar=`\\%
 +\write \contentsfile \temp %
 +\unnumbnoderef %
 +\penalty 10000 %
 +}}
 +
 +% These are variants which are not "outer", so they can appear in @ifinfo.
 +% Actually, they should now be obsolete; ordinary section commands should work.
 +\def\infotop{\parsearg\unnumberedzzz}
 +\def\infounnumbered{\parsearg\unnumberedzzz}
 +\def\infounnumberedsec{\parsearg\unnumberedseczzz}
 +\def\infounnumberedsubsec{\parsearg\unnumberedsubseczzz}
 +\def\infounnumberedsubsubsec{\parsearg\unnumberedsubsubseczzz}
 +
 +\def\infoappendix{\parsearg\appendixzzz}
 +\def\infoappendixsec{\parsearg\appendixseczzz}
 +\def\infoappendixsubsec{\parsearg\appendixsubseczzz}
 +\def\infoappendixsubsubsec{\parsearg\appendixsubsubseczzz}
 +
 +\def\infochapter{\parsearg\chapterzzz}
 +\def\infosection{\parsearg\sectionzzz}
 +\def\infosubsection{\parsearg\subsectionzzz}
 +\def\infosubsubsection{\parsearg\subsubsectionzzz}
 +
 +% These macros control what the section commands do, according
 +% to what kind of chapter we are in (ordinary, appendix, or unnumbered).
 +% Define them by default for a numbered chapter.
 +\global\let\section = \numberedsec
 +\global\let\subsection = \numberedsubsec
 +\global\let\subsubsection = \numberedsubsubsec
 +
 +% Define @majorheading, @heading and @subheading
 +
 +% NOTE on use of \vbox for chapter headings, section headings, and
 +% such:
 +%	1) We use \vbox rather than the earlier \line to permit
 +%	   overlong headings to fold.
 +%	2) \hyphenpenalty is set to 10000 because hyphenation in a
 +%	   heading is obnoxious; this forbids it.
 +%       3) Likewise, headings look best if no \parindent is used, and
 +%          if justification is not attempted.  Hence \raggedright.
 +
 +
 +\def\majorheading{\parsearg\majorheadingzzz}
 +\def\majorheadingzzz #1{%
 +{\advance\chapheadingskip by 10pt \chapbreak }%
 +{\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000
 +                  \parindent=0pt\raggedright
 +                  \rm #1\hfill}}\bigskip \par\penalty 200}
 +
 +\def\chapheading{\parsearg\chapheadingzzz}
 +\def\chapheadingzzz #1{\chapbreak %
 +{\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000
 +                  \parindent=0pt\raggedright
 +                  \rm #1\hfill}}\bigskip \par\penalty 200}
 +
 +\def\heading{\parsearg\secheadingi}
 +
 +\def\subheading{\parsearg\subsecheadingi}
 +
 +\def\subsubheading{\parsearg\subsubsecheadingi}
 +
 +% These macros generate a chapter, section, etc. heading only
 +% (including whitespace, linebreaking, etc. around it),
 +% given all the information in convenient, parsed form.
 +
 +%%% Args are the skip and penalty (usually negative)
 +\def\dobreak#1#2{\par\ifdim\lastskip<#1\removelastskip\penalty#2\vskip#1\fi}
 +
 +\def\setchapterstyle #1 {\csname CHAPF#1\endcsname}
 +
 +%%% Define plain chapter starts, and page on/off switching for it
 +% Parameter controlling skip before chapter headings (if needed)
 +
 +\newskip \chapheadingskip \chapheadingskip = 30pt plus 8pt minus 4pt
 +
 +\def\chapbreak{\dobreak \chapheadingskip {-4000}}
 +\def\chappager{\par\vfill\supereject}
 +\def\chapoddpage{\chappager \ifodd\pageno \else \hbox to 0pt{} \chappager\fi}
 +
 +\def\setchapternewpage #1 {\csname CHAPPAG#1\endcsname}
 +
 +\def\CHAPPAGoff{
 +\global\let\pchapsepmacro=\chapbreak
 +\global\let\pagealignmacro=\chappager}
 +
 +\def\CHAPPAGon{
 +\global\let\pchapsepmacro=\chappager
 +\global\let\pagealignmacro=\chappager
 +\global\def\HEADINGSon{\HEADINGSsingle}}
 +
 +\def\CHAPPAGodd{
 +\global\let\pchapsepmacro=\chapoddpage
 +\global\let\pagealignmacro=\chapoddpage
 +\global\def\HEADINGSon{\HEADINGSdouble}}
 +
 +\CHAPPAGon
 +
 +\def\CHAPFplain{
 +\global\let\chapmacro=\chfplain
 +\global\let\unnumbchapmacro=\unnchfplain}
 +
 +\def\chfplain #1#2{%
 +  \pchapsepmacro
 +  {%
 +    \chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000
 +                     \parindent=0pt\raggedright
 +                     \rm #2\enspace #1}%
 +  }%
 +  \bigskip
 +  \penalty5000
 +}
 +
 +\def\unnchfplain #1{%
 +\pchapsepmacro %
 +{\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000
 +                  \parindent=0pt\raggedright
 +                  \rm #1\hfill}}\bigskip \par\penalty 10000 %
 +}
 +\CHAPFplain % The default
 +
 +\def\unnchfopen #1{%
 +\chapoddpage {\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000
 +                       \parindent=0pt\raggedright
 +                       \rm #1\hfill}}\bigskip \par\penalty 10000 %
 +}
 +
 +\def\chfopen #1#2{\chapoddpage {\chapfonts
 +\vbox to 3in{\vfil \hbox to\hsize{\hfil #2} \hbox to\hsize{\hfil #1} \vfil}}%
 +\par\penalty 5000 %
 +}
 +
 +\def\CHAPFopen{
 +\global\let\chapmacro=\chfopen
 +\global\let\unnumbchapmacro=\unnchfopen}
 +
 +% Parameter controlling skip before section headings.
 +
 +\newskip \subsecheadingskip  \subsecheadingskip = 17pt plus 8pt minus 4pt
 +\def\subsecheadingbreak{\dobreak \subsecheadingskip {-500}}
 +
 +\newskip \secheadingskip  \secheadingskip = 21pt plus 8pt minus 4pt
 +\def\secheadingbreak{\dobreak \secheadingskip {-1000}}
 +
 +% @paragraphindent  is defined for the Info formatting commands only.
 +\let\paragraphindent=\comment
 +
 +% Section fonts are the base font at magstep2, which produces
 +% a size a bit more than 14 points in the default situation.	
 +
 +\def\secheading #1#2#3{\secheadingi {#2.#3\enspace #1}}
 +\def\plainsecheading #1{\secheadingi {#1}}
 +\def\secheadingi #1{{\advance \secheadingskip by \parskip %
 +\secheadingbreak}%
 +{\secfonts \vbox{\hyphenpenalty=10000\tolerance=5000
 +                 \parindent=0pt\raggedright
 +                 \rm #1\hfill}}%
 +\ifdim \parskip<10pt \kern 10pt\kern -\parskip\fi \penalty 10000 }
 +
 +
 +% Subsection fonts are the base font at magstep1, 
 +% which produces a size of 12 points.
 +
 +\def\subsecheading #1#2#3#4{\subsecheadingi {#2.#3.#4\enspace #1}}
 +\def\subsecheadingi #1{{\advance \subsecheadingskip by \parskip %
 +\subsecheadingbreak}%
 +{\subsecfonts \vbox{\hyphenpenalty=10000\tolerance=5000
 +                     \parindent=0pt\raggedright
 +                     \rm #1\hfill}}%
 +\ifdim \parskip<10pt \kern 10pt\kern -\parskip\fi \penalty 10000 }
 +
 +\def\subsubsecfonts{\subsecfonts} % Maybe this should change:
 +				  % Perhaps make sssec fonts scaled
 +				  % magstep half
 +\def\subsubsecheading #1#2#3#4#5{\subsubsecheadingi {#2.#3.#4.#5\enspace #1}}
 +\def\subsubsecheadingi #1{{\advance \subsecheadingskip by \parskip %
 +\subsecheadingbreak}%
 +{\subsubsecfonts \vbox{\hyphenpenalty=10000\tolerance=5000
 +                       \parindent=0pt\raggedright
 +                       \rm #1\hfill}}%
 +\ifdim \parskip<10pt \kern 10pt\kern -\parskip\fi \penalty 10000}
 +
 +
 +\message{toc printing,}
 +
 +% Finish up the main text and prepare to read what we've written
 +% to \contentsfile.
 +
 +\newskip\contentsrightmargin \contentsrightmargin=1in
 +\def\startcontents#1{%
 +   \pagealignmacro
 +   \immediate\closeout \contentsfile
 +   \ifnum \pageno>0
 +      \pageno = -1		% Request roman numbered pages.
 +   \fi
 +   % Don't need to put `Contents' or `Short Contents' in the headline. 
 +   % It is abundantly clear what they are.
 +   \unnumbchapmacro{#1}\def\thischapter{}%
 +   \begingroup   		% Set up to handle contents files properly.
 +      \catcode`\\=0  \catcode`\{=1  \catcode`\}=2  \catcode`\@=11
 +      \raggedbottom             % Worry more about breakpoints than the bottom.
 +      \advance\hsize by -\contentsrightmargin % Don't use the full line length.
 +}
 +
 +  
 +% Normal (long) toc.
 +\outer\def\contents{%
 +   \startcontents{Table of Contents}%
 +      \input \jobname.toc
 +   \endgroup
 +   \vfill \eject
 +}
 +
 +% And just the chapters.
 +\outer\def\summarycontents{%
 +   \startcontents{Short Contents}%
 +      %
 +      \let\chapentry = \shortchapentry
 +      \let\unnumbchapentry = \shortunnumberedentry
 +      % We want a true roman here for the page numbers.
 +      \secfonts
 +      \let\rm=\shortcontrm \let\bf=\shortcontbf \let\sl=\shortcontsl
 +      \rm
 +      \advance\baselineskip by 1pt % Open it up a little.
 +      \def\secentry ##1##2##3##4{}
 +      \def\unnumbsecentry ##1##2{}
 +      \def\subsecentry ##1##2##3##4##5{}
 +      \def\unnumbsubsecentry ##1##2{}
 +      \def\subsubsecentry ##1##2##3##4##5##6{}
 +      \def\unnumbsubsubsecentry ##1##2{}
 +      \input \jobname.toc
 +   \endgroup
 +   \vfill \eject
 +}
 +\let\shortcontents = \summarycontents
 +
 +% These macros generate individual entries in the table of contents.
 +% The first argument is the chapter or section name.
 +% The last argument is the page number.
 +% The arguments in between are the chapter number, section number, ...
 +
 +% Chapter-level things, for both the long and short contents.
 +\def\chapentry#1#2#3{\dochapentry{#2\labelspace#1}{#3}}
 +
 +% See comments in \dochapentry re vbox and related settings
 +\def\shortchapentry#1#2#3{%
 +   \vbox{\hyphenpenalty=10000\tolerance=5000
 +    \parindent=0pt\strut\raggedright
 +    {#2\labelspace #1}\dotfill\doshortpageno{#3}}%
 +}
 +
 +\def\unnumbchapentry#1#2{\dochapentry{#1}{#2}}
 +\def\shortunnumberedentry#1#2{%
 +   \vbox{\hyphenpenalty=10000\tolerance=5000
 +    \parindent=0pt\strut\raggedright
 +    #1\dotfill\doshortpageno{#2}}%
 +}
 +
 +% Sections.
 +\def\secentry#1#2#3#4{\dosecentry{#2.#3\labelspace#1}{#4}}
 +\def\unnumbsecentry#1#2{\dosecentry{#1}{#2}}
 +
 +% Subsections.
 +\def\subsecentry#1#2#3#4#5{\dosubsecentry{#2.#3.#4\labelspace#1}{#5}}
 +\def\unnumbsubsecentry#1#2{\dosubsecentry{#1}{#2}}
 +
 +% And subsubsections.
 +\def\subsubsecentry#1#2#3#4#5#6{%
 +  \dosubsubsecentry{#2.#3.#4.#5\labelspace#1}{#6}}
 +\def\unnumbsubsubsecentry#1#2{\dosubsubsecentry{#1}{#2}}
 +
 +
 +% This parameter controls the indentation of the various levels.
 +\newdimen\tocindent \tocindent = 3pc
 +
 +% Now for the actual typesetting. In all these, #1 is the text and #2 is the 
 +% page number.
 +%
 +% If the toc has to be broken over pages, we would want to be at chapters 
 +% if at all possible; hence the \penalty.
 +\def\dochapentry#1#2{%
 +   \penalty-300 \vskip\baselineskip
 +   % This \vbox (and similar ones in dosecentry etc.) used to be a
 +   % \line; changed to permit linebreaks for long headings.  See
 +   % comments above \majorheading.  Here we also use \strut to
 +   % keep the top end of the vbox from jamming up against the previous
 +   % entry in the table of contents.
 +   \vbox{\chapentryfonts
 +     \hyphenpenalty=10000\tolerance=5000 % this line and next introduced
 +     \parindent=0pt\strut\raggedright    % with \line -> \vbox change
 +     #1\dotfill
 +     \dopageno{#2}}%
 +   \nobreak\vskip .25\baselineskip
 +}
 +
 +\def\dosecentry#1#2{%
 +   \vbox{\secentryfonts \leftskip=\tocindent
 +    \hyphenpenalty=10000\tolerance=5000
 +    \parindent=0pt\strut\raggedright #1\dotfill
 +    \dopageno{#2}}%
 +}
 +
 +\def\dosubsecentry#1#2{%
 +   \vbox{\subsecentryfonts \leftskip=2\tocindent
 +    \hyphenpenalty=10000\tolerance=5000
 +    \parindent=0pt\strut\raggedright #1\dotfill
 +    \dopageno{#2}}%
 +}
 +
 +\def\dosubsubsecentry#1#2{%
 +   \vbox{\subsubsecentryfonts \leftskip=3\tocindent
 +    \hyphenpenalty=10000\tolerance=5000
 +    \parindent=0pt\strut\raggedright #1\dotfill
 +    \dopageno{#2}}%
 +}
 +
 +% Space between chapter (or whatever) number and the title.
 +\def\labelspace{\hskip1em \relax}
 +
 +\def\dopageno#1{{\rm #1}}
 +\def\doshortpageno#1{{\rm #1}}
 +
 +\def\chapentryfonts{\secfonts \rm}
 +\def\secentryfonts{\textfonts}
 +\let\subsecentryfonts = \textfonts
 +\let\subsubsecentryfonts = \textfonts
 +
 +
 +\message{environments,}
 +
 +% Since these characters are used in examples, it should be an even number of 
 +% \tt widths. Each \tt character is 1en, so two makes it 1em.
 +% Furthermore, these definitions must come after we define our fonts.
 +\newbox\dblarrowbox    \newbox\longdblarrowbox
 +\newbox\pushcharbox    \newbox\bullbox
 +\newbox\equivbox       \newbox\errorbox
 +
 +\let\ptexequiv = \equiv
 +
 +%{\tentt
 +%\global\setbox\dblarrowbox = \hbox to 1em{\hfil$\Rightarrow$\hfil}
 +%\global\setbox\longdblarrowbox = \hbox to 1em{\hfil$\mapsto$\hfil}
 +%\global\setbox\pushcharbox = \hbox to 1em{\hfil$\dashv$\hfil}
 +%\global\setbox\equivbox = \hbox to 1em{\hfil$\ptexequiv$\hfil}
 +% Adapted from the manmac format (p.420 of TeXbook)
 +%\global\setbox\bullbox = \hbox to 1em{\kern.15em\vrule height .75ex width .85ex
 +%                                      depth .1ex\hfil}
 +%}
 +
 +\def\point{$\star$}
 +
 +\def\result{\leavevmode\raise.15ex\hbox to 1em{\hfil$\Rightarrow$\hfil}}
 +\def\expansion{\leavevmode\raise.1ex\hbox to 1em{\hfil$\mapsto$\hfil}}
 +\def\print{\leavevmode\lower.1ex\hbox to 1em{\hfil$\dashv$\hfil}}
 +
 +\def\equiv{\leavevmode\lower.1ex\hbox to 1em{\hfil$\ptexequiv$\hfil}}
 +
 +% Adapted from the TeXbook's \boxit.
 +{\tentt \global\dimen0 = 3em}% Width of the box.
 +\dimen2 = .55pt % Thickness of rules
 +% The text. (`r' is open on the right, `e' somewhat less so on the left.)
 +\setbox0 = \hbox{\kern-.75pt \tensf error\kern-1.5pt}
 +
 +\global\setbox\errorbox=\hbox to \dimen0{\hfil
 +   \hsize = \dimen0 \advance\hsize by -5.8pt % Space to left+right.
 +   \advance\hsize by -2\dimen2 % Rules.
 +   \vbox{
 +      \hrule height\dimen2
 +      \hbox{\vrule width\dimen2 \kern3pt          % Space to left of text.
 +         \vtop{\kern2.4pt \box0 \kern2.4pt}% Space above/below.
 +         \kern3pt\vrule width\dimen2}% Space to right.
 +      \hrule height\dimen2}
 +    \hfil}
 +
 +% The @error{} command.
 +\def\error{\leavevmode\lower.7ex\copy\errorbox}
 +
 +% @tex ... @end tex    escapes into raw Tex temporarily.
 +% One exception: @ is still an escape character, so that @end tex works.
 +% But \@ or @@ will get a plain tex @ character.
 +
 +\def\tex{\begingroup
 +\catcode `\\=0 \catcode `\{=1 \catcode `\}=2
 +\catcode `\$=3 \catcode `\&=4 \catcode `\#=6
 +\catcode `\^=7 \catcode `\_=8 \catcode `\~=13 \let~=\tie
 +\catcode `\%=14
 +\catcode 43=12
 +\catcode`\"=12
 +\catcode`\==12
 +\catcode`\|=12
 +\catcode`\<=12
 +\catcode`\>=12
 +\escapechar=`\\
 +%
 +\let\{=\ptexlbrace
 +\let\}=\ptexrbrace
 +\let\.=\ptexdot
 +\let\*=\ptexstar
 +\let\dots=\ptexdots
 +\def\@{@}%
 +\let\bullet=\ptexbullet
 +\let\b=\ptexb \let\c=\ptexc \let\i=\ptexi \let\t=\ptext \let\l=\ptexl
 +\let\L=\ptexL
 +%
 +\let\Etex=\endgroup}
 +
 +% Define @lisp ... @endlisp.
 +% @lisp does a \begingroup so it can rebind things,
 +% including the definition of @endlisp (which normally is erroneous).
 +
 +% Amount to narrow the margins by for @lisp.
 +\newskip\lispnarrowing \lispnarrowing=0.4in
 +
 +% This is the definition that ^M gets inside @lisp
 +% phr: changed space to \null, to avoid overfull hbox problems.
 +{\obeyspaces%
 +\gdef\lisppar{\null\endgraf}}
 +
 +% Cause \obeyspaces to make each Space cause a word-separation
 +% rather than the default which is that it acts punctuation.
 +% This is because space in tt font looks funny.
 +{\obeyspaces %
 +\gdef\sepspaces{\def {\ }}}
 +
 +\newskip\aboveenvskipamount \aboveenvskipamount= 0pt
 +\def\aboveenvbreak{{\advance\aboveenvskipamount by \parskip
 +\endgraf \ifdim\lastskip<\aboveenvskipamount
 +\removelastskip \penalty-50 \vskip\aboveenvskipamount \fi}}
 +
 +\def\afterenvbreak{\endgraf \ifdim\lastskip<\aboveenvskipamount
 +\removelastskip \penalty-50 \vskip\aboveenvskipamount \fi}
 +
 +% \nonarrowing is a flag.  If "set", @lisp etc don't narrow margins.
 +\let\nonarrowing=\relax
 +
 +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 +% \cartouche: draw rectangle w/rounded corners around argument
 +\font\circle=lcircle10
 +\newdimen\circthick
 +\newdimen\cartouter\newdimen\cartinner
 +\newskip\normbskip\newskip\normpskip\newskip\normlskip
 +\circthick=\fontdimen8\circle
 +%
 +\def\ctl{{\circle\char'013\hskip -6pt}}% 6pt from pl file: 1/2charwidth
 +\def\ctr{{\hskip 6pt\circle\char'010}}
 +\def\cbl{{\circle\char'012\hskip -6pt}}
 +\def\cbr{{\hskip 6pt\circle\char'011}}
 +\def\carttop{\hbox to \cartouter{\hskip\lskip
 +	\ctl\leaders\hrule height\circthick\hfil\ctr
 +	\hskip\rskip}}
 +\def\cartbot{\hbox to \cartouter{\hskip\lskip
 +	\cbl\leaders\hrule height\circthick\hfil\cbr
 +	\hskip\rskip}}
 +%
 +\newskip\lskip\newskip\rskip
 +
 +\long\def\cartouche{%
 +\begingroup
 +	\lskip=\leftskip \rskip=\rightskip
 +	\leftskip=0pt\rightskip=0pt %we want these *outside*.
 +	\cartinner=\hsize \advance\cartinner by-\lskip 
 +		 	  \advance\cartinner by-\rskip
 +	\cartouter=\hsize
 +	\advance\cartouter by 18pt % allow for 3pt kerns on either
 +%				     side, and for 6pt waste from
 +%				     each corner char
 +	\normbskip=\baselineskip \normpskip=\parskip \normlskip=\lineskip
 +	% Flag to tell @lisp, etc., not to narrow margin.
 +	\let\nonarrowing=\comment
 +	\vbox\bgroup
 +		\baselineskip=0pt\parskip=0pt\lineskip=0pt
 +		\carttop
 +		\hbox\bgroup
 +			\hskip\lskip
 +			\vrule\kern3pt
 +			\vbox\bgroup
 +				\hsize=\cartinner
 +				\kern3pt
 +				\begingroup
 +					\baselineskip=\normbskip
 +					\lineskip=\normlskip
 +					\parskip=\normpskip
 +					\vskip -\parskip
 +\def\Ecartouche{%
 +				\endgroup
 +				\kern3pt
 +			\egroup
 +			\kern3pt\vrule
 +			\hskip\rskip
 +		\egroup
 +		\cartbot
 +	\egroup
 +\endgroup
 +}}	
 +
 +\def\lisp{\aboveenvbreak
 +\begingroup\inENV % This group ends at the end of the @lisp body
 +\hfuzz=12truept % Don't be fussy
 +% Make spaces be word-separators rather than space tokens.
 +\sepspaces %
 +% Single space lines
 +\singlespace %
 +% The following causes blank lines not to be ignored
 +% by adding a space to the end of each line.
 +\let\par=\lisppar
 +\def\Elisp{\endgroup\afterenvbreak}%
 +\parskip=0pt
 +% @cartouche defines \nonarrowing to inhibit narrowing
 +% at next level down.
 +\ifx\nonarrowing\relax
 +\advance \leftskip by \lispnarrowing
 +\exdentamount=\lispnarrowing
 +\let\exdent=\nofillexdent
 +\let\nonarrowing=\relax
 +\fi
 +\parindent=0pt
 +\obeyspaces \obeylines \tt \rawbackslash
 +\def\next##1{}\next}
 +
 +
 +\let\example=\lisp
 +\def\Eexample{\Elisp}
 +
 +\let\smallexample=\lisp
 +\def\Esmallexample{\Elisp}
 +
 +% Macro for 9 pt. examples, necessary to print with 5" lines.
 +% From Pavel@xerox.  This is not really used unless the
 +% @smallbook command is given.
 +
 +\def\smalllispx{\aboveenvbreak\begingroup\inENV
 +%			This group ends at the end of the @lisp body
 +\hfuzz=12truept % Don't be fussy
 +% Make spaces be word-separators rather than space tokens.
 +\sepspaces %
 +% Single space lines
 +\singlespace %
 +% The following causes blank lines not to be ignored
 +% by adding a space to the end of each line.
 +\let\par=\lisppar
 +\def\Esmalllisp{\endgroup\afterenvbreak}%
 +%%%% Smaller baseline skip for small examples.
 +\baselineskip 10pt
 +\parskip=0pt
 +% @cartouche defines \nonarrowing to inhibit narrowing
 +% at next level down.
 +\ifx\nonarrowing\relax
 +\advance \leftskip by \lispnarrowing
 +\exdentamount=\lispnarrowing
 +\let\exdent=\nofillexdent
 +\let\nonarrowing=\relax
 +\fi
 +\parindent=0pt
 +\obeyspaces \obeylines \ninett \indexfonts \rawbackslash
 +\def\next##1{}\next}
 +
 +% This is @display; same as @lisp except use roman font.
 +
 +\def\display{\begingroup\inENV %This group ends at the end of the @display body
 +\aboveenvbreak
 +% Make spaces be word-separators rather than space tokens.
 +\sepspaces %
 +% Single space lines
 +\singlespace %
 +% The following causes blank lines not to be ignored
 +% by adding a space to the end of each line.
 +\let\par=\lisppar
 +\def\Edisplay{\endgroup\afterenvbreak}%
 +\parskip=0pt
 +% @cartouche defines \nonarrowing to inhibit narrowing
 +% at next level down.
 +\ifx\nonarrowing\relax
 +\advance \leftskip by \lispnarrowing
 +\exdentamount=\lispnarrowing
 +\let\exdent=\nofillexdent
 +\let\nonarrowing=\relax
 +\fi
 +\parindent=0pt
 +\obeyspaces \obeylines
 +\def\next##1{}\next}
 +
 +% This is @format; same as @lisp except use roman font and don't narrow margins
 +
 +\def\format{\begingroup\inENV %This group ends at the end of the @format body
 +\aboveenvbreak
 +% Make spaces be word-separators rather than space tokens.
 +\sepspaces %
 +\singlespace %
 +% The following causes blank lines not to be ignored
 +% by adding a space to the end of each line.
 +\let\par=\lisppar
 +\def\Eformat{\endgroup\afterenvbreak}
 +\parskip=0pt \parindent=0pt
 +\obeyspaces \obeylines
 +\def\next##1{}\next}
 +
 +% @flushleft and @flushright
 +
 +\def\flushleft{%
 +\begingroup\inENV %This group ends at the end of the @format body
 +\aboveenvbreak
 +% Make spaces be word-separators rather than space tokens.
 +\sepspaces %
 +% The following causes blank lines not to be ignored
 +% by adding a space to the end of each line.
 +% This also causes @ to work when the directive name
 +% is terminated by end of line.
 +\let\par=\lisppar
 +\def\Eflushleft{\endgroup\afterenvbreak}%
 +\parskip=0pt \parindent=0pt
 +\obeyspaces \obeylines
 +\def\next##1{}\next}
 +
 +\def\flushright{%
 +\begingroup\inENV %This group ends at the end of the @format body
 +\aboveenvbreak
 +% Make spaces be word-separators rather than space tokens.
 +\sepspaces %
 +% The following causes blank lines not to be ignored
 +% by adding a space to the end of each line.
 +% This also causes @ to work when the directive name
 +% is terminated by end of line.
 +\let\par=\lisppar
 +\def\Eflushright{\endgroup\afterenvbreak}%
 +\parskip=0pt \parindent=0pt
 +\advance \leftskip by 0pt plus 1fill
 +\obeyspaces \obeylines
 +\def\next##1{}\next}
 +
 +% @quotation - narrow the margins.
 +
 +\def\quotation{%
 +\begingroup\inENV %This group ends at the end of the @quotation body
 +{\parskip=0pt  % because we will skip by \parskip too, later
 +\aboveenvbreak}%
 +\singlespace
 +\parindent=0pt
 +\def\Equotation{\par\endgroup\afterenvbreak}%
 +% @cartouche defines \nonarrowing to inhibit narrowing
 +% at next level down.
 +\ifx\nonarrowing\relax
 +\advance \leftskip by \lispnarrowing
 +\advance \rightskip by \lispnarrowing
 +\exdentamount=\lispnarrowing
 +\let\nonarrowing=\relax
 +\fi}
 +
 +\message{defuns,}
 +% Define formatter for defuns
 +% First, allow user to change definition object font (\df) internally
 +\def\setdeffont #1 {\csname DEF#1\endcsname}
 +
 +\newskip\defbodyindent \defbodyindent=.4in
 +\newskip\defargsindent \defargsindent=50pt
 +\newskip\deftypemargin \deftypemargin=12pt
 +\newskip\deflastargmargin \deflastargmargin=18pt
 +
 +\newcount\parencount
 +% define \functionparens, which makes ( and ) and & do special things.
 +% \functionparens affects the group it is contained in.
 +\def\activeparens{%
 +\catcode`\(=\active \catcode`\)=\active \catcode`\&=\active
 +\catcode`\[=\active \catcode`\]=\active}
 +{\activeparens % Now, smart parens don't turn on until &foo (see \amprm)
 +\gdef\functionparens{\boldbrax\let&=\amprm\parencount=0 }
 +\gdef\boldbrax{\let(=\opnr\let)=\clnr\let[=\lbrb\let]=\rbrb}
 +
 +% Definitions of (, ) and & used in args for functions.
 +% This is the definition of ( outside of all parentheses.
 +\gdef\oprm#1 {{\rm\char`\(}#1 \bf \let(=\opnested %
 +\global\advance\parencount by 1 }
 +%
 +% This is the definition of ( when already inside a level of parens.
 +\gdef\opnested{\char`\(\global\advance\parencount by 1 }
 +%
 +\gdef\clrm{% Print a paren in roman if it is taking us back to depth of 0.
 +% also in that case restore the outer-level definition of (.
 +\ifnum \parencount=1 {\rm \char `\)}\sl \let(=\oprm \else \char `\) \fi
 +\global\advance \parencount by -1 }
 +% If we encounter &foo, then turn on ()-hacking afterwards
 +\gdef\amprm#1 {{\rm\}\let(=\oprm \let)=\clrm\ }
 +%
 +\gdef\normalparens{\boldbrax\let&=\ampnr}
 +} % End of definition inside \activeparens
 +%% These parens (in \boldbrax) actually are a little bolder than the
 +%% contained text.  This is especially needed for [ and ]
 +\def\opnr{{\sf\char`\(}} \def\clnr{{\sf\char`\)}} \def\ampnr{\&}
 +\def\lbrb{{\bf\char`\[}} \def\rbrb{{\bf\char`\]}}
 +
 +% First, defname, which formats the header line itself.
 +% #1 should be the function name.
 +% #2 should be the type of definition, such as "Function".
 +
 +\def\defname #1#2{%
 +% Get the values of \leftskip and \rightskip as they were
 +% outside the @def...
 +\dimen2=\leftskip
 +\advance\dimen2 by -\defbodyindent
 +\dimen3=\rightskip
 +\advance\dimen3 by -\defbodyindent
 +\noindent        %
 +\setbox0=\hbox{\hskip \deflastargmargin{\rm #2}\hskip \deftypemargin}%
 +\dimen0=\hsize \advance \dimen0 by -\wd0 % compute size for first line
 +\dimen1=\hsize \advance \dimen1 by -\defargsindent %size for continuations
 +\parshape 2 0in \dimen0 \defargsindent \dimen1     %
 +% Now output arg 2 ("Function" or some such)
 +% ending at \deftypemargin from the right margin,
 +% but stuck inside a box of width 0 so it does not interfere with linebreaking
 +{% Adjust \hsize to exclude the ambient margins,
 +% so that \rightline will obey them.
 +\advance \hsize by -\dimen2 \advance \hsize by -\dimen3
 +\rlap{\rightline{{\rm #2}\hskip \deftypemargin}}}%
 +% Make all lines underfull and no complaints:
 +\tolerance=10000 \hbadness=10000    
 +\advance\leftskip by -\defbodyindent
 +\exdentamount=\defbodyindent
 +{\df #1}\enskip        % Generate function name
 +}
 +
 +% Actually process the body of a definition
 +% #1 should be the terminating control sequence, such as \Edefun.
 +% #2 should be the "another name" control sequence, such as \defunx.
 +% #3 should be the control sequence that actually processes the header,
 +%    such as \defunheader.
 +
 +\def\defparsebody #1#2#3{\begingroup\inENV% Environment for definitionbody
 +\medbreak %
 +% Define the end token that this defining construct specifies
 +% so that it will exit this group.
 +\def#1{\endgraf\endgroup\medbreak}%
 +\def#2{\begingroup\obeylines\activeparens\spacesplit#3}%
 +\parindent=0in
 +\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent
 +\exdentamount=\defbodyindent
 +\begingroup %
 +\catcode 61=\active %
 +\obeylines\activeparens\spacesplit#3}
 +
 +\def\defmethparsebody #1#2#3#4 {\begingroup\inENV %
 +\medbreak %
 +% Define the end token that this defining construct specifies
 +% so that it will exit this group.
 +\def#1{\endgraf\endgroup\medbreak}%
 +\def#2##1 {\begingroup\obeylines\activeparens\spacesplit{#3{##1}}}%
 +\parindent=0in
 +\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent
 +\exdentamount=\defbodyindent
 +\begingroup\obeylines\activeparens\spacesplit{#3{#4}}}
 +
 +\def\defopparsebody #1#2#3#4#5 {\begingroup\inENV %
 +\medbreak %
 +% Define the end token that this defining construct specifies
 +% so that it will exit this group.
 +\def#1{\endgraf\endgroup\medbreak}%
 +\def#2##1 ##2 {\def#4{##1}%
 +\begingroup\obeylines\activeparens\spacesplit{#3{##2}}}%
 +\parindent=0in
 +\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent
 +\exdentamount=\defbodyindent
 +\begingroup\obeylines\activeparens\spacesplit{#3{#5}}}
 +
 +% These parsing functions are similar to the preceding ones
 +% except that they do not make parens into active characters.
 +% These are used for "variables" since they have no arguments.
 +
 +\def\defvarparsebody #1#2#3{\begingroup\inENV% Environment for definitionbody
 +\medbreak %
 +% Define the end token that this defining construct specifies
 +% so that it will exit this group.
 +\def#1{\endgraf\endgroup\medbreak}%
 +\def#2{\begingroup\obeylines\spacesplit#3}%
 +\parindent=0in
 +\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent
 +\exdentamount=\defbodyindent
 +\begingroup %
 +\catcode 61=\active %
 +\obeylines\spacesplit#3}
 +
 +\def\defvrparsebody #1#2#3#4 {\begingroup\inENV %
 +\medbreak %
 +% Define the end token that this defining construct specifies
 +% so that it will exit this group.
 +\def#1{\endgraf\endgroup\medbreak}%
 +\def#2##1 {\begingroup\obeylines\spacesplit{#3{##1}}}%
 +\parindent=0in
 +\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent
 +\exdentamount=\defbodyindent
 +\begingroup\obeylines\spacesplit{#3{#4}}}
 +
 +\def\defopvarparsebody #1#2#3#4#5 {\begingroup\inENV %
 +\medbreak %
 +% Define the end token that this defining construct specifies
 +% so that it will exit this group.
 +\def#1{\endgraf\endgroup\medbreak}%
 +\def#2##1 ##2 {\def#4{##1}%
 +\begingroup\obeylines\spacesplit{#3{##2}}}%
 +\parindent=0in
 +\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent
 +\exdentamount=\defbodyindent
 +\begingroup\obeylines\spacesplit{#3{#5}}}
 +
 +% Split up #2 at the first space token.
 +% call #1 with two arguments:
 +%  the first is all of #2 before the space token,
 +%  the second is all of #2 after that space token.
 +% If #2 contains no space token, all of it is passed as the first arg
 +% and the second is passed as empty.
 +
 +{\obeylines
 +\gdef\spacesplit#1#2^^M{\endgroup\spacesplitfoo{#1}#2 \relax\spacesplitfoo}%
 +\long\gdef\spacesplitfoo#1#2 #3#4\spacesplitfoo{%
 +\ifx\relax #3%
 +#1{#2}{}\else #1{#2}{#3#4}\fi}}
 +
 +% So much for the things common to all kinds of definitions.
 +
 +% Define @defun.
 +
 +% First, define the processing that is wanted for arguments of \defun
 +% Use this to expand the args and terminate the paragraph they make up
 +
 +\def\defunargs #1{\functionparens \sl
 +% Expand, preventing hyphenation at `-' chars.
 +% Note that groups don't affect changes in \hyphenchar.
 +\hyphenchar\tensl=0
 +#1%
 +\hyphenchar\tensl=45
 +\ifnum\parencount=0 \else \errmessage{unbalanced parens in @def arguments}\fi%
 +\interlinepenalty=10000
 +\advance\rightskip by 0pt plus 1fil
 +\endgraf\penalty 10000\vskip -\parskip\penalty 10000%
 +}
 +
 +\def\deftypefunargs #1{%
 +% Expand, preventing hyphenation at `-' chars.
 +% Note that groups don't affect changes in \hyphenchar.
 +\functionparens
 +\code{#1}%
 +\interlinepenalty=10000
 +\advance\rightskip by 0pt plus 1fil
 +\endgraf\penalty 10000\vskip -\parskip\penalty 10000%
 +}
 +
 +% Do complete processing of one @defun or @defunx line already parsed.
 +
 +% @deffn Command forward-char nchars
 +
 +\def\deffn{\defmethparsebody\Edeffn\deffnx\deffnheader}
 +
 +\def\deffnheader #1#2#3{\doind {fn}{\code{#2}}%
 +\begingroup\defname {#2}{#1}\defunargs{#3}\endgroup %
 +\catcode 61=\other % Turn off change made in \defparsebody
 +}
 +
 +% @defun == @deffn Function
 +
 +\def\defun{\defparsebody\Edefun\defunx\defunheader}
 +
 +\def\defunheader #1#2{\doind {fn}{\code{#1}}% Make entry in function index
 +\begingroup\defname {#1}{Function}%
 +\defunargs {#2}\endgroup %
 +\catcode 61=\other % Turn off change made in \defparsebody
 +}
 +
 +% @deftypefun int foobar (int @var{foo}, float @var{bar})
 +
 +\def\deftypefun{\defparsebody\Edeftypefun\deftypefunx\deftypefunheader}
 +
 +% #1 is the data type.  #2 is the name and args.
 +\def\deftypefunheader #1#2{\deftypefunheaderx{#1}#2 \relax}
 +% #1 is the data type, #2 the name, #3 the args.
 +\def\deftypefunheaderx #1#2 #3\relax{%
 +\doind {fn}{\code{#2}}% Make entry in function index
 +\begingroup\defname {\code{#1} #2}{Function}%
 +\deftypefunargs {#3}\endgroup %
 +\catcode 61=\other % Turn off change made in \defparsebody
 +}
 +
 +% @deftypefn {Library Function} int foobar (int @var{foo}, float @var{bar})
 +
 +\def\deftypefn{\defmethparsebody\Edeftypefn\deftypefnx\deftypefnheader}
 +
 +% #1 is the classification.  #2 is the data type.  #3 is the name and args.
 +\def\deftypefnheader #1#2#3{\deftypefnheaderx{#1}{#2}#3 \relax}
 +% #1 is the classification, #2 the data type, #3 the name, #4 the args.
 +\def\deftypefnheaderx #1#2#3 #4\relax{%
 +\doind {fn}{\code{#3}}% Make entry in function index
 +\begingroup\defname {\code{#2} #3}{#1}%
 +\deftypefunargs {#4}\endgroup %
 +\catcode 61=\other % Turn off change made in \defparsebody
 +}
 +
 +% @defmac == @deffn Macro
 +
 +\def\defmac{\defparsebody\Edefmac\defmacx\defmacheader}
 +
 +\def\defmacheader #1#2{\doind {fn}{\code{#1}}% Make entry in function index
 +\begingroup\defname {#1}{Macro}%
 +\defunargs {#2}\endgroup %
 +\catcode 61=\other % Turn off change made in \defparsebody
 +}
 +
 +% @defspec == @deffn Special Form
 +
 +\def\defspec{\defparsebody\Edefspec\defspecx\defspecheader}
 +
 +\def\defspecheader #1#2{\doind {fn}{\code{#1}}% Make entry in function index
 +\begingroup\defname {#1}{Special Form}%
 +\defunargs {#2}\endgroup %
 +\catcode 61=\other % Turn off change made in \defparsebody
 +}
 +
 +% This definition is run if you use @defunx
 +% anywhere other than immediately after a @defun or @defunx.
 +
 +\def\deffnx #1 {\errmessage{@deffnx in invalid context}}
 +\def\defunx #1 {\errmessage{@defunx in invalid context}}
 +\def\defmacx #1 {\errmessage{@defmacx in invalid context}}
 +\def\defspecx #1 {\errmessage{@defspecx in invalid context}}
 +\def\deftypefnx #1 {\errmessage{@deftypefnx in invalid context}}
 +\def\deftypeunx #1 {\errmessage{@deftypeunx in invalid context}}
 +
 +% @defmethod, and so on
 +
 +% @defop {Funny Method} foo-class frobnicate argument
 +
 +\def\defop #1 {\def\defoptype{#1}%
 +\defopparsebody\Edefop\defopx\defopheader\defoptype}
 +
 +\def\defopheader #1#2#3{%
 +\dosubind {fn}{\code{#2}}{on #1}% Make entry in function index
 +\begingroup\defname {#2}{\defoptype{} on #1}%
 +\defunargs {#3}\endgroup %
 +}
 +
 +% @defmethod == @defop Method
 +
 +\def\defmethod{\defmethparsebody\Edefmethod\defmethodx\defmethodheader}
 +
 +\def\defmethodheader #1#2#3{%
 +\dosubind {fn}{\code{#2}}{on #1}% entry in function index
 +\begingroup\defname {#2}{Method on #1}%
 +\defunargs {#3}\endgroup %
 +}
 +
 +% @defcv {Class Option} foo-class foo-flag
 +
 +\def\defcv #1 {\def\defcvtype{#1}%
 +\defopvarparsebody\Edefcv\defcvx\defcvarheader\defcvtype}
 +
 +\def\defcvarheader #1#2#3{%
 +\dosubind {vr}{\code{#2}}{of #1}% Make entry in var index
 +\begingroup\defname {#2}{\defcvtype{} of #1}%
 +\defvarargs {#3}\endgroup %
 +}
 +
 +% @defivar == @defcv {Instance Variable}
 +
 +\def\defivar{\defvrparsebody\Edefivar\defivarx\defivarheader}
 +
 +\def\defivarheader #1#2#3{%
 +\dosubind {vr}{\code{#2}}{of #1}% Make entry in var index
 +\begingroup\defname {#2}{Instance Variable of #1}%
 +\defvarargs {#3}\endgroup %
 +}
 +
 +% These definitions are run if you use @defmethodx, etc.,
 +% anywhere other than immediately after a @defmethod, etc.
 +
 +\def\defopx #1 {\errmessage{@defopx in invalid context}}
 +\def\defmethodx #1 {\errmessage{@defmethodx in invalid context}}
 +\def\defcvx #1 {\errmessage{@defcvx in invalid context}}
 +\def\defivarx #1 {\errmessage{@defivarx in invalid context}}
 +
 +% Now @defvar
 +
 +% First, define the processing that is wanted for arguments of @defvar.
 +% This is actually simple: just print them in roman.
 +% This must expand the args and terminate the paragraph they make up
 +\def\defvarargs #1{\normalparens #1%
 +\interlinepenalty=10000
 +\endgraf\penalty 10000\vskip -\parskip\penalty 10000}
 +
 +% @defvr Counter foo-count
 +
 +\def\defvr{\defvrparsebody\Edefvr\defvrx\defvrheader}
 +
 +\def\defvrheader #1#2#3{\doind {vr}{\code{#2}}%
 +\begingroup\defname {#2}{#1}\defvarargs{#3}\endgroup}
 +
 +% @defvar == @defvr Variable
 +
 +\def\defvar{\defvarparsebody\Edefvar\defvarx\defvarheader}
 +
 +\def\defvarheader #1#2{\doind {vr}{\code{#1}}% Make entry in var index
 +\begingroup\defname {#1}{Variable}%
 +\defvarargs {#2}\endgroup %
 +}
 +
 +% @defopt == @defvr {User Option}
 +
 +\def\defopt{\defvarparsebody\Edefopt\defoptx\defoptheader}
 +
 +\def\defoptheader #1#2{\doind {vr}{\code{#1}}% Make entry in var index
 +\begingroup\defname {#1}{User Option}%
 +\defvarargs {#2}\endgroup %
 +}
 +
 +% @deftypevar int foobar
 +
 +\def\deftypevar{\defvarparsebody\Edeftypevar\deftypevarx\deftypevarheader}
 +
 +% #1 is the data type.  #2 is the name.
 +\def\deftypevarheader #1#2{%
 +\doind {vr}{\code{#2}}% Make entry in variables index
 +\begingroup\defname {\code{#1} #2}{Variable}%
 +\interlinepenalty=10000
 +\endgraf\penalty 10000\vskip -\parskip\penalty 10000
 +\endgroup}
 +
 +% @deftypevr {Global Flag} int enable
 +
 +\def\deftypevr{\defvrparsebody\Edeftypevr\deftypevrx\deftypevrheader}
 +
 +\def\deftypevrheader #1#2#3{\doind {vr}{\code{#3}}%
 +\begingroup\defname {\code{#2} #3}{#1}
 +\interlinepenalty=10000
 +\endgraf\penalty 10000\vskip -\parskip\penalty 10000
 +\endgroup}
 +
 +% This definition is run if you use @defvarx
 +% anywhere other than immediately after a @defvar or @defvarx.
 +
 +\def\defvrx #1 {\errmessage{@defvrx in invalid context}}
 +\def\defvarx #1 {\errmessage{@defvarx in invalid context}}
 +\def\defoptx #1 {\errmessage{@defoptx in invalid context}}
 +\def\deftypevarx #1 {\errmessage{@deftypevarx in invalid context}}
 +\def\deftypevrx #1 {\errmessage{@deftypevrx in invalid context}}
 +
 +% Now define @deftp
 +% Args are printed in bold, a slight difference from @defvar.
 +
 +\def\deftpargs #1{\bf \defvarargs{#1}}
 +
 +% @deftp Class window height width ...
 +
 +\def\deftp{\defvrparsebody\Edeftp\deftpx\deftpheader}
 +
 +\def\deftpheader #1#2#3{\doind {tp}{\code{#2}}%
 +\begingroup\defname {#2}{#1}\deftpargs{#3}\endgroup}
 +
 +% This definition is run if you use @deftpx, etc
 +% anywhere other than immediately after a @deftp, etc.
 +
 +\def\deftpx #1 {\errmessage{@deftpx in invalid context}}
 +
 +\message{cross reference,}
 +% Define cross-reference macros
 +\newwrite \auxfile
 +
 +\newif\ifhavexrefs  % True if xref values are known.
 +\newif\ifwarnedxrefs  % True if we warned once that they aren't known.
 +
 +% \setref{foo} defines a cross-reference point named foo.
 +
 +\def\setref#1{%
 +%\dosetq{#1-title}{Ytitle}%
 +\dosetq{#1-pg}{Ypagenumber}%
 +\dosetq{#1-snt}{Ysectionnumberandtype}}
 +
 +\def\unnumbsetref#1{%
 +%\dosetq{#1-title}{Ytitle}%
 +\dosetq{#1-pg}{Ypagenumber}%
 +\dosetq{#1-snt}{Ynothing}}
 +
 +\def\appendixsetref#1{%
 +%\dosetq{#1-title}{Ytitle}%
 +\dosetq{#1-pg}{Ypagenumber}%
 +\dosetq{#1-snt}{Yappendixletterandtype}}
 +
 +% \xref, \pxref, and \ref generate cross-references to specified points.
 +% For \xrefX, #1 is the node name, #2 the name of the Info
 +% cross-reference, #3 the printed node name, #4 the name of the Info
 +% file, #5 the name of the printed manual.  All but the node name can be
 +% omitted.
 +% 
 +\def\pxref#1{see \xrefX[#1,,,,,,,]}
 +\def\xref#1{See \xrefX[#1,,,,,,,]}
 +\def\ref#1{\xrefX[#1,,,,,,,]}
 +\def\xrefX[#1,#2,#3,#4,#5,#6]{\begingroup%
 +\def\printedmanual{\ignorespaces #5}%
 +\def\printednodename{\ignorespaces #3}%
 +%
 +\setbox1=\hbox{\printedmanual}%
 +\setbox0=\hbox{\printednodename}%
 +\ifdim \wd0=0pt%
 +\def\printednodename{\ignorespaces #1}%
 +%%% Uncommment the following line to make the actual chapter or section title
 +%%% appear inside the square brackets.
 +%\def\printednodename{#1-title}%
 +\fi%
 +%
 +%
 +% If we use \unhbox0 and \unhbox1 to print the node names, TeX does
 +% not insert empty discretionaries after hyphens, which means that it
 +% will not find a line break at a hyphen in a node names.  Since some
 +% manuals are best written with fairly long node names, containing
 +% hyphens, this is a loss.  Therefore, we simply give the text of
 +% the node name again, so it is as if TeX is seeing it for the first
 +% time.
 +\ifdim \wd1>0pt
 +section ``\printednodename'' in \cite{\printedmanual}%
 +\else%
 +\turnoffactive%
 +\refx{#1-snt}{} [\printednodename], page\tie\refx{#1-pg}{}%
 +\fi
 +\endgroup}
 +
 +% \dosetq is the interface for calls from other macros
 +
 +% Use \turnoffactive so that punctuation chars such as underscore
 +% work in node names.
 +\def\dosetq #1#2{{\let\folio=0 \turnoffactive%
 +\edef\next{\write\auxfile{\internalsetq {#1}{#2}}}%
 +\next}}
 +
 +% \internalsetq {foo}{page} expands into
 +% CHARACTERS 'xrdef {foo}{...expansion of \Ypage...}
 +% When the aux file is read, ' is the escape character
 +
 +\def\internalsetq #1#2{'xrdef {#1}{\csname #2\endcsname}}
 +
 +% Things to be expanded by \internalsetq
 +
 +\def\Ypagenumber{\folio}
 +
 +\def\Ytitle{\thischapter}
 +
 +\def\Ynothing{}
 +
 +\def\Ysectionnumberandtype{%
 +\ifnum\secno=0 Chapter\xreftie\the\chapno %
 +\else \ifnum \subsecno=0 Section\xreftie\the\chapno.\the\secno %
 +\else \ifnum \subsubsecno=0 %
 +Section\xreftie\the\chapno.\the\secno.\the\subsecno %
 +\else %
 +Section\xreftie\the\chapno.\the\secno.\the\subsecno.\the\subsubsecno %
 +\fi \fi \fi }
 +
 +\def\Yappendixletterandtype{%
 +\ifnum\secno=0 Appendix\xreftie'char\the\appendixno{}%
 +\else \ifnum \subsecno=0 Section\xreftie'char\the\appendixno.\the\secno %
 +\else \ifnum \subsubsecno=0 %
 +Section\xreftie'char\the\appendixno.\the\secno.\the\subsecno %
 +\else %
 +Section\xreftie'char\the\appendixno.\the\secno.\the\subsecno.\the\subsubsecno %
 +\fi \fi \fi }
 +
 +\gdef\xreftie{'tie}
 +
 +% Use TeX 3.0's \inputlineno to get the line number, for better error
 +% messages, but if we're using an old version of TeX, don't do anything.
 +% 
 +\ifx\inputlineno\thisisundefined
 +  \let\linenumber = \empty % Non-3.0.
 +\else
 +  \def\linenumber{\the\inputlineno:\space}
 +\fi
 +
 +% Define \refx{NAME}{SUFFIX} to reference a cross-reference string named NAME.
 +% If its value is nonempty, SUFFIX is output afterward.
 +
 +\def\refx#1#2{%
 +  \expandafter\ifx\csname X#1\endcsname\relax
 +    % If not defined, say something at least.
 +    $\langle$un\-de\-fined$\rangle$%
 +    \ifhavexrefs
 +      \message{\linenumber Undefined cross reference `#1'.}%
 +    \else
 +      \ifwarnedxrefs\else
 +        \global\warnedxrefstrue
 +        \message{Cross reference values unknown; you must run TeX again.}%
 +      \fi
 +    \fi
 +  \else
 +    % It's defined, so just use it.
 +    \csname X#1\endcsname
 +  \fi
 +  #2% Output the suffix in any case.
 +}
 +
 +% Read the last existing aux file, if any.  No error if none exists.
 +
 +% This is the macro invoked by entries in the aux file.
 +\def\xrdef #1#2{
 +{\catcode`\'=\other\expandafter \gdef \csname X#1\endcsname {#2}}}
 +
 +\def\readauxfile{%
 +\begingroup
 +\catcode `\^^@=\other
 +\catcode `\=\other
 +\catcode `\=\other
 +\catcode `\^^C=\other
 +\catcode `\^^D=\other
 +\catcode `\^^E=\other
 +\catcode `\^^F=\other
 +\catcode `\^^G=\other
 +\catcode `\^^H=\other
 +\catcode `\=\other
 +\catcode `\^^L=\other
 +\catcode `\=\other
 +\catcode `\=\other
 +\catcode `\=\other
 +\catcode `\=\other
 +\catcode `\=\other
 +\catcode `\=\other
 +\catcode `\=\other
 +\catcode `\=\other
 +\catcode `\=\other
 +\catcode `\=\other
 +\catcode `\=\other
 +\catcode `\=\other
 +\catcode 26=\other
 +\catcode `\^^[=\other
 +\catcode `\^^\=\other
 +\catcode `\^^]=\other
 +\catcode `\^^^=\other
 +\catcode `\^^_=\other
 +\catcode `\@=\other
 +\catcode `\^=\other
 +\catcode `\~=\other
 +\catcode `\[=\other
 +\catcode `\]=\other
 +\catcode`\"=\other
 +\catcode`\_=\other
 +\catcode`\|=\other
 +\catcode`\<=\other
 +\catcode`\>=\other
 +\catcode `\$=\other
 +\catcode `\#=\other
 +\catcode `\&=\other
 +% the aux file uses ' as the escape.
 +% Turn off \ as an escape so we do not lose on
 +% entries which were dumped with control sequences in their names.
 +% For example, 'xrdef {$\leq $-fun}{page ...} made by @defun ^^
 +% Reference to such entries still does not work the way one would wish,
 +% but at least they do not bomb out when the aux file is read in.
 +\catcode `\{=1 \catcode `\}=2
 +\catcode `\%=\other
 +\catcode `\'=0
 +\catcode `\\=\other
 +\openin 1 \jobname.aux
 +\ifeof 1 \else \closein 1 \input \jobname.aux \global\havexrefstrue
 +\fi
 +% Open the new aux file.  Tex will close it automatically at exit.
 +\openout \auxfile=\jobname.aux
 +\endgroup}
 +
 +
 +% Footnotes.
 +
 +\newcount \footnoteno
 +
 +% The trailing space in the following definition for supereject is
 +% vital for proper filling; pages come out unaligned when you do a
 +% pagealignmacro call if that space before the closing brace is
 +% removed.
 +\def\supereject{\par\penalty -20000\footnoteno =0 }
 +
 +% @footnotestyle is meaningful for info output only..
 +\let\footnotestyle=\comment
 +
 +\let\ptexfootnote=\footnote
 +
 +{\catcode `\@=11
 +\long\gdef\footnote #1{\global\advance \footnoteno by \@ne
 +\unskip
 +\edef\thisfootno{$^{\the\footnoteno}$}%
 +\let\@sf\empty
 +\ifhmode\edef\@sf{\spacefactor\the\spacefactor}\/\fi
 +\thisfootno\@sf \footnotezzz{#1}}
 +% \parsearg\footnotezzz}
 +
 +\long\gdef\footnotezzz #1{\insert\footins{
 +\interlinepenalty\interfootnotelinepenalty
 +\splittopskip\ht\strutbox % top baseline for broken footnotes
 +\splitmaxdepth\dp\strutbox \floatingpenalty\@MM
 +\leftskip\z@skip \rightskip\z@skip \spaceskip\z@skip \xspaceskip\z@skip
 +\footstrut\parindent=\defaultparindent\hang\textindent{\thisfootno}#1\strut}}
 +
 +}%end \catcode `\@=11
 +
 +% End of control word definitions.
 +
 +\message{and turning on texinfo input format.}
 +
 +\def\openindices{%
 +   \newindex{cp}%
 +   \newcodeindex{fn}%
 +   \newcodeindex{vr}%
 +   \newcodeindex{tp}%
 +   \newcodeindex{ky}%
 +   \newcodeindex{pg}%
 +}
 +
 +% Set some numeric style parameters, for 8.5 x 11 format.
 +
 +%\hsize = 6.5in
 +\newdimen\defaultparindent \defaultparindent = 15pt
 +\parindent = \defaultparindent
 +\parskip 18pt plus 1pt
 +\baselineskip 15pt
 +\advance\topskip by 1.2cm
 +
 +% Prevent underfull vbox error messages.
 +\vbadness=10000
 +
 +% Following George Bush, just get rid of widows and orphans.
 +\widowpenalty=10000
 +\clubpenalty=10000
 +
 +% Use TeX 3.0's \emergencystretch to help line breaking, but if we're
 +% using an old version of TeX, don't do anything.  We want the amount of
 +% stretch added to depend on the line length, hence the dependence on
 +% \hsize.  This makes it come to about 9pt for the 8.5x11 format.
 +% 
 +\ifx\emergencystretch\thisisundefined \else
 +  \emergencystretch = \hsize
 +  \divide\emergencystretch by 45
 +\fi
 +
 +% Use @smallbook to reset parameters for 7x9.5 format  (or else 7x9.25)
 +\def\smallbook{
 +\global\lispnarrowing = 0.3in
 +\global\baselineskip 12pt
 +\advance\topskip by -1cm
 +\global\parskip 3pt plus 1pt
 +\global\hsize = 5in
 +\global\doublecolumnhsize=2.4in \global\doublecolumnvsize=15.0in
 +\global\vsize=7.5in
 +\global\tolerance=700
 +\global\hfuzz=1pt
 +\global\contentsrightmargin=0pt
 +
 +\global\pagewidth=\hsize
 +\global\pageheight=\vsize
 +
 +\global\let\smalllisp=\smalllispx
 +\global\let\smallexample=\smalllispx
 +\global\def\Esmallexample{\Esmalllisp}
 +}
 +
 +% Use @afourpaper to print on European A4 paper.
 +\def\afourpaper{
 +\global\tolerance=700
 +\global\hfuzz=1pt
 +\global\baselineskip=12pt
 +\global\parskip 15pt plus 1pt
 +
 +\global\vsize= 53\baselineskip
 +\advance\vsize by \topskip
 +%\global\hsize=   5.85in     % A4 wide 10pt
 +\global\hsize=  6.5in
 +\global\outerhsize=\hsize
 +\global\advance\outerhsize by 0.5in
 +\global\outervsize=\vsize
 +\global\advance\outervsize by 0.6in
 +\global\doublecolumnhsize=\hsize
 +\global\divide\doublecolumnhsize by 2
 +\global\advance\doublecolumnhsize by -0.1in
 +\global\doublecolumnvsize=\vsize
 +\global\multiply\doublecolumnvsize by 2
 +\global\advance\doublecolumnvsize by 0.1in
 +
 +\global\pagewidth=\hsize
 +\global\pageheight=\vsize
 +}
 +
 +%% For a final copy, take out the rectangles
 +%% that mark overfull boxes (in case you have decided
 +%% that the text looks ok even though it passes the margin).
 +\def\finalout{\overfullrule=0pt}
 +
 +% Define macros to output various characters with catcode for normal text.
 +\catcode`\"=\other
 +\catcode`\~=\other
 +\catcode`\^=\other
 +\catcode`\_=\other
 +\catcode`\|=\other
 +\catcode`\<=\other
 +\catcode`\>=\other
 +\catcode`\+=\other
 +\def\normaldoublequote{"}
 +\def\normaltilde{~}
 +\def\normalcaret{^}
 +\def\normalunderscore{_}
 +\def\normalverticalbar{|}
 +\def\normalless{<}
 +\def\normalgreater{>}
 +\def\normalplus{+}
 +
 +% This macro is used to make a character print one way in ttfont
 +% where it can probably just be output, and another way in other fonts,
 +% where something hairier probably needs to be done.
 +%
 +% #1 is what to print if we are indeed using \tt; #2 is what to print
 +% otherwise.  Since all the Computer Modern typewriter fonts have zero
 +% interword stretch (and shrink), and it is reasonable to expect all
 +% typewriter fonts to have this, we can check that font parameter.
 +% 
 +\def\ifusingtt#1#2{\ifdim \fontdimen3\the\font=0pt #1\else #2\fi}
 +
 +% Turn off all special characters except @
 +% (and those which the user can use as if they were ordinary).
 +% Most of these we simply print from the \tt font, but for some, we can
 +% use math or other variants that look better in normal text.
 +
 +\catcode`\"=\active
 +\def\activedoublequote{{\tt \char '042}}
 +\let"=\activedoublequote
 +\catcode`\~=\active
 +\def~{{\tt \char '176}}
 +\chardef\hat=`\^
 +\catcode`\^=\active
 +\def^{{\tt \hat}}
 +
 +\catcode`\_=\active
 +\def_{\ifusingtt\normalunderscore\_}
 +% Subroutine for the previous macro.
 +\def\_{\lvvmode \kern.06em \vbox{\hrule width.3em height.1ex}}
 +
 +% \lvvmode is equivalent in function to \leavevmode.
 +% Using \leavevmode runs into trouble when written out to
 +% an index file due to the expansion of \leavevmode into ``\unhbox
 +% \voidb@x'' ---which looks to TeX like ``\unhbox \voidb\x'' due to our
 +% magic tricks with @.
 +\def\lvvmode{\vbox to 0pt{}}
 +
 +\catcode`\|=\active
 +\def|{{\tt \char '174}}
 +\chardef \less=`\<
 +\catcode`\<=\active
 +\def<{{\tt \less}}
 +\chardef \gtr=`\>
 +\catcode`\>=\active
 +\def>{{\tt \gtr}}
 +\catcode`\+=\active
 +\def+{{\tt \char 43}}
 +%\catcode 27=\active
 +%\def^^[{$\diamondsuit$}
 +
 +% Used sometimes to turn off (effectively) the active characters
 +% even after parsing them.
 +\def\turnoffactive{\let"=\normaldoublequote
 +\let~=\normaltilde
 +\let^=\normalcaret
 +\let_=\normalunderscore
 +\let|=\normalverticalbar
 +\let<=\normalless
 +\let>=\normalgreater
 +\let+=\normalplus}
 +
 +% Set up an active definition for =, but don't enable it most of the time.
 +{\catcode`\==\active
 +\global\def={{\tt \char 61}}}
 +
 +\catcode`\@=0
 +
 +% \rawbackslashxx output one backslash character in current font
 +\global\chardef\rawbackslashxx=`\\
 +%{\catcode`\\=\other
 +%@gdef@rawbackslashxx{\}}
 +
 +% \rawbackslash redefines \ as input to do \rawbackslashxx.
 +{\catcode`\\=\active
 +@gdef@rawbackslash{@let\=@rawbackslashxx }}
 +
 +% \normalbackslash outputs one backslash in fixed width font.
 +\def\normalbackslash{{\tt\rawbackslashxx}}
 +
 +% Say @foo, not \foo, in error messages.
 +\escapechar=`\@
 +
 +% \catcode 17=0   % Define control-q
 +\catcode`\\=\active
 +
 +% If a .fmt file is being used, we don't want the `\input texinfo' to show up.
 +% That is what \eatinput is for; after that, the `\' should revert to printing 
 +% a backslash.
 +%
 +@gdef@eatinput input texinfo{@fixbackslash}
 +@global@let\ = @eatinput
 +
 +% On the other hand, perhaps the file did not have a `\input texinfo'. Then
 +% the first `\{ in the file would cause an error. This macro tries to fix 
 +% that, assuming it is called before the first `\' could plausibly occur.
 +% 
 +@gdef@fixbackslash{@ifx\@eatinput @let\ = @normalbackslash @fi}
 +
 +%% These look ok in all fonts, so just make them not special.  The @rm below
 +%% makes sure that the current font starts out as the newly loaded cmr10
 +@catcode`@$=@other @catcode`@%=@other @catcode`@&=@other @catcode`@#=@other
 +
 +@textfonts
 +@rm
 +
 +@c Local variables:
 +@c page-delimiter: "^\\\\message"
 +@c End:
diff --cc test/manual/etags/y-src/cccp.c
index 022fbe0a72f,00000000000..380243c6fa4
mode 100644,000000..100644
--- a/test/manual/etags/y-src/cccp.c
+++ b/test/manual/etags/y-src/cccp.c
@@@ -1,2203 -1,0 +1,2203 @@@
 +/* A Bison parser, made from cccp.y
 +   by GNU bison 1.32.  */
 +
 +#define YYBISON 1  /* Identify Bison output.  */
 +
 +# define	INT	257
 +# define	CHAR	258
 +# define	NAME	259
 +# define	ERROR	260
 +# define	OR	261
 +# define	AND	262
 +# define	EQUAL	263
 +# define	NOTEQUAL	264
 +# define	LEQ	265
 +# define	GEQ	266
 +# define	LSH	267
 +# define	RSH	268
 +# define	UNARY	269
 +
 +#line 26 "y-src/cccp.y"
 +
 +#include "config.h"
 +#include <setjmp.h>
 +/* #define YYDEBUG 1 */
 +
 +#ifdef MULTIBYTE_CHARS
 +#include <stdlib.h>
 +#include <locale.h>
 +#endif
 +
 +#include <stdio.h>
 +
 +typedef unsigned char U_CHAR;
 +
 +/* This is used for communicating lists of keywords with cccp.c.  */
 +struct arglist {
 +  struct arglist *next;
 +  U_CHAR *name;
 +  int length;
 +  int argno;
 +};
 +
 +/* Define a generic NULL if one hasn't already been defined.  */
 +
 +#ifndef NULL
 +#define NULL 0
 +#endif
 +
 +#ifndef GENERIC_PTR
 +#if defined (USE_PROTOTYPES) ? USE_PROTOTYPES : defined (__STDC__)
 +#define GENERIC_PTR void *
 +#else
 +#define GENERIC_PTR char *
 +#endif
 +#endif
 +
 +#ifndef NULL_PTR
 +#define NULL_PTR ((GENERIC_PTR)0)
 +#endif
 +
 +int yylex ();
 +void yyerror ();
 +int expression_value;
 +
 +static jmp_buf parse_return_error;
 +
 +/* Nonzero means count most punctuation as part of a name.  */
 +static int keyword_parsing = 0;
 +
 +/* some external tables of character types */
 +extern unsigned char is_idstart[], is_idchar[], is_hor_space[];
 +
 +extern char *xmalloc ();
 +
 +/* Flag for -pedantic.  */
 +extern int pedantic;
 +
 +/* Flag for -traditional.  */
 +extern int traditional;
 +
 +#ifndef CHAR_TYPE_SIZE
 +#define CHAR_TYPE_SIZE BITS_PER_UNIT
 +#endif
 +
 +#ifndef INT_TYPE_SIZE
 +#define INT_TYPE_SIZE BITS_PER_WORD
 +#endif
 +
 +#ifndef LONG_TYPE_SIZE
 +#define LONG_TYPE_SIZE BITS_PER_WORD
 +#endif
 +
 +#ifndef WCHAR_TYPE_SIZE
 +#define WCHAR_TYPE_SIZE INT_TYPE_SIZE
 +#endif
 +
 +/* Yield nonzero if adding two numbers with A's and B's signs can yield a
 +   number with SUM's sign, where A, B, and SUM are all C integers.  */
 +#define possible_sum_sign(a, b, sum) ((((a) ^ (b)) | ~ ((a) ^ (sum))) < 0)
 +
 +static void integer_overflow ();
 +static long left_shift ();
 +static long right_shift ();
 +
 +#line 111 "y-src/cccp.y"
 +#ifndef YYSTYPE
 +typedef union {
 +  struct constant {long value; int unsignedp;} integer;
 +  struct name {U_CHAR *address; int length;} name;
 +  struct arglist *keywords;
 +  int voidval;
 +  char *sval;
 +} yystype;
 +# define YYSTYPE yystype
 +#endif
 +#ifndef YYDEBUG
 +# define YYDEBUG 0
 +#endif
 +
 +
 +
 +#define	YYFINAL		73
 +#define	YYFLAG		-32768
 +#define	YYNTBASE	34
 +
 +/* YYTRANSLATE(YYLEX) -- Bison token number corresponding to YYLEX. */
 +#define YYTRANSLATE(x) ((unsigned)(x) <= 269 ? yytranslate[x] : 39)
 +
 +/* YYTRANSLATE[YYLEX] -- Bison token number corresponding to YYLEX. */
 +static const char yytranslate[] =
 +{
 +       0,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,    29,     2,    31,     2,    27,    14,     2,
 +      32,    33,    25,    23,     9,    24,     2,    26,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     8,     2,
 +      17,     2,    18,     7,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,    13,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,    12,     2,    30,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     1,     3,     4,     5,
 +       6,    10,    11,    15,    16,    19,    20,    21,    22,    28
 +};
 +
 +#if YYDEBUG
 +static const short yyprhs[] =
 +{
 +       0,     0,     2,     4,     8,    11,    14,    17,    20,    23,
 +      24,    31,    35,    39,    43,    47,    51,    55,    59,    63,
 +      67,    71,    75,    79,    83,    87,    91,    95,    99,   103,
 +     107,   113,   115,   117,   119,   120,   125
 +};
 +static const short yyrhs[] =
 +{
 +      35,     0,    36,     0,    35,     9,    36,     0,    24,    36,
 +       0,    29,    36,     0,    23,    36,     0,    30,    36,     0,
 +      31,     5,     0,     0,    31,     5,    37,    32,    38,    33,
 +       0,    32,    35,    33,     0,    36,    25,    36,     0,    36,
 +      26,    36,     0,    36,    27,    36,     0,    36,    23,    36,
 +       0,    36,    24,    36,     0,    36,    21,    36,     0,    36,
 +      22,    36,     0,    36,    15,    36,     0,    36,    16,    36,
 +       0,    36,    19,    36,     0,    36,    20,    36,     0,    36,
 +      17,    36,     0,    36,    18,    36,     0,    36,    14,    36,
 +       0,    36,    13,    36,     0,    36,    12,    36,     0,    36,
 +      11,    36,     0,    36,    10,    36,     0,    36,     7,    36,
 +       8,    36,     0,     3,     0,     4,     0,     5,     0,     0,
 +      32,    38,    33,    38,     0,     5,    38,     0
 +};
 +
 +#endif
 +
 +#if YYDEBUG
 +/* YYRLINE[YYN] -- source line where rule number YYN was defined. */
 +static const short yyrline[] =
 +{
 +       0,   143,   148,   149,   156,   161,   164,   166,   169,   173,
 +     173,   180,   185,   197,   212,   223,   230,   237,   243,   249,
 +     252,   255,   261,   267,   273,   279,   282,   285,   288,   291,
 +     294,   297,   299,   301,   306,   308,   321
 +};
 +#endif
 +
 +
 +#if (YYDEBUG) || defined YYERROR_VERBOSE
 +
 +/* YYTNAME[TOKEN_NUM] -- String name of the token TOKEN_NUM. */
 +static const char *const yytname[] =
 +{
 +  "$", "error", "$undefined.", "INT", "CHAR", "NAME", "ERROR", "'?'", "':'", 
 +  "','", "OR", "AND", "'|'", "'^'", "'&'", "EQUAL", "NOTEQUAL", "'<'", 
 +  "'>'", "LEQ", "GEQ", "LSH", "RSH", "'+'", "'-'", "'*'", "'/'", "'%'", 
 +  "UNARY", "'!'", "'~'", "'#'", "'('", "')'", "start", "exp1", "exp", 
 +  "@1", "keywords", NULL
 +};
 +#endif
 +
 +/* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */
 +static const short yyr1[] =
 +{
 +       0,    34,    35,    35,    36,    36,    36,    36,    36,    37,
 +      36,    36,    36,    36,    36,    36,    36,    36,    36,    36,
 +      36,    36,    36,    36,    36,    36,    36,    36,    36,    36,
 +      36,    36,    36,    36,    38,    38,    38
 +};
 +
 +/* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */
 +static const short yyr2[] =
 +{
 +       0,     1,     1,     3,     2,     2,     2,     2,     2,     0,
 +       6,     3,     3,     3,     3,     3,     3,     3,     3,     3,
 +       3,     3,     3,     3,     3,     3,     3,     3,     3,     3,
 +       5,     1,     1,     1,     0,     4,     2
 +};
 +
 +/* YYDEFACT[S] -- default rule to reduce with in state S when YYTABLE
 +   doesn't specify something else to do.  Zero means the default is an
 +   error. */
 +static const short yydefact[] =
 +{
 +       0,    31,    32,    33,     0,     0,     0,     0,     0,     0,
 +       1,     2,     6,     4,     5,     7,     8,     0,     0,     0,
 +       0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
 +       0,     0,     0,     0,     0,     0,     0,     0,     0,    11,
 +       3,     0,    29,    28,    27,    26,    25,    19,    20,    23,
 +      24,    21,    22,    17,    18,    15,    16,    12,    13,    14,
 +      34,     0,    34,    34,     0,    30,    36,     0,    10,    34,
 +      35,     0,     0,     0
 +};
 +
 +static const short yydefgoto[] =
 +{
 +      71,    10,    11,    38,    64
 +};
 +
 +static const short yypact[] =
 +{
 +      31,-32768,-32768,-32768,    31,    31,    31,    31,     4,    31,
 +       3,    80,-32768,-32768,-32768,-32768,     6,    32,    31,    31,
 +      31,    31,    31,    31,    31,    31,    31,    31,    31,    31,
 +      31,    31,    31,    31,    31,    31,    31,    31,     7,-32768,
 +      80,    59,    97,   113,   128,   142,   155,    25,    25,   162,
 +     162,   162,   162,   167,   167,   -19,   -19,-32768,-32768,-32768,
 +       5,    31,     5,     5,   -20,    80,-32768,    20,-32768,     5,
 +  -32768,    40,    56,-32768
 +};
 +
 +static const short yypgoto[] =
 +{
 +  -32768,    49,    -4,-32768,   -58
 +};
 +
 +
 +#define	YYLAST		194
 +
 +
 +static const short yytable[] =
 +{
 +      12,    13,    14,    15,    66,    67,    35,    36,    37,    16,
 +      62,    70,    18,    68,    40,    41,    42,    43,    44,    45,
 +      46,    47,    48,    49,    50,    51,    52,    53,    54,    55,
 +      56,    57,    58,    59,     1,     2,     3,    63,    -9,    60,
 +      72,    18,    27,    28,    29,    30,    31,    32,    33,    34,
 +      35,    36,    37,    69,     4,     5,    73,    65,    17,     0,
 +       6,     7,     8,     9,     0,    39,    19,    61,     0,    20,
 +      21,    22,    23,    24,    25,    26,    27,    28,    29,    30,
 +      31,    32,    33,    34,    35,    36,    37,    19,     0,     0,
 +      20,    21,    22,    23,    24,    25,    26,    27,    28,    29,
 +      30,    31,    32,    33,    34,    35,    36,    37,    21,    22,
 +      23,    24,    25,    26,    27,    28,    29,    30,    31,    32,
 +      33,    34,    35,    36,    37,    22,    23,    24,    25,    26,
 +      27,    28,    29,    30,    31,    32,    33,    34,    35,    36,
 +      37,    23,    24,    25,    26,    27,    28,    29,    30,    31,
 +      32,    33,    34,    35,    36,    37,    24,    25,    26,    27,
 +      28,    29,    30,    31,    32,    33,    34,    35,    36,    37,
 +      25,    26,    27,    28,    29,    30,    31,    32,    33,    34,
 +      35,    36,    37,    31,    32,    33,    34,    35,    36,    37,
 +      33,    34,    35,    36,    37
 +};
 +
 +static const short yycheck[] =
 +{
 +       4,     5,     6,     7,    62,    63,    25,    26,    27,     5,
 +       5,    69,     9,    33,    18,    19,    20,    21,    22,    23,
 +      24,    25,    26,    27,    28,    29,    30,    31,    32,    33,
 +      34,    35,    36,    37,     3,     4,     5,    32,    32,    32,
 +       0,     9,    17,    18,    19,    20,    21,    22,    23,    24,
 +      25,    26,    27,    33,    23,    24,     0,    61,     9,    -1,
 +      29,    30,    31,    32,    -1,    33,     7,     8,    -1,    10,
 +      11,    12,    13,    14,    15,    16,    17,    18,    19,    20,
 +      21,    22,    23,    24,    25,    26,    27,     7,    -1,    -1,
 +      10,    11,    12,    13,    14,    15,    16,    17,    18,    19,
 +      20,    21,    22,    23,    24,    25,    26,    27,    11,    12,
 +      13,    14,    15,    16,    17,    18,    19,    20,    21,    22,
 +      23,    24,    25,    26,    27,    12,    13,    14,    15,    16,
 +      17,    18,    19,    20,    21,    22,    23,    24,    25,    26,
 +      27,    13,    14,    15,    16,    17,    18,    19,    20,    21,
 +      22,    23,    24,    25,    26,    27,    14,    15,    16,    17,
 +      18,    19,    20,    21,    22,    23,    24,    25,    26,    27,
 +      15,    16,    17,    18,    19,    20,    21,    22,    23,    24,
 +      25,    26,    27,    21,    22,    23,    24,    25,    26,    27,
 +      23,    24,    25,    26,    27
 +};
 +/* -*-C-*-  Note some compilers choke on comments on `#line' lines.  */
 +#line 3 "/usr/share/bison/bison.simple"
 +
 +/* Skeleton output parser for bison,
-    Copyright (C) 1984, 1989-1990, 2000-2001, 2016 Free Software
++   Copyright (C) 1984, 1989-1990, 2000-2001, 2016-2017 Free Software
 +   Foundation, Inc.
 +
 +   This program is free software; you can redistribute it and/or modify
 +   it under the terms of the GNU General Public License as published by
 +   the Free Software Foundation; either version 2, or (at your option)
 +   any later version.
 +
 +   This program is distributed in the hope that it will be useful,
 +   but WITHOUT ANY WARRANTY; without even the implied warranty of
 +   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +   GNU General Public License for more details.
 +
 +   You should have received a copy of the GNU General Public License
 +   along with this program; if not, write to the Free Software
 +   Foundation, Inc., 59 Temple Place - Suite 330,
 +   Boston, MA 02111-1307, USA.  */
 +
 +/* As a special exception, when this file is copied by Bison into a
 +   Bison output file, you may use that output file without restriction.
 +   This special exception was added by the Free Software Foundation
 +   in version 1.24 of Bison.  */
 +
 +/* This is the parser code that is written into each bison parser when
 +   the %semantic_parser declaration is not specified in the grammar.
 +   It was written by Richard Stallman by simplifying the hairy parser
 +   used when %semantic_parser is specified.  */
 +
 +/* All symbols defined below should begin with yy or YY, to avoid
 +   infringing on user name space.  This should be done even for local
 +   variables, as they might otherwise be expanded by user macros.
 +   There are some unavoidable exceptions within include files to
 +   define necessary library symbols; they are noted "INFRINGES ON
 +   USER NAME SPACE" below.  */
 +
 +#ifdef __cplusplus
 +# define YYSTD(x) std::x
 +#else
 +# define YYSTD(x) x
 +#endif
 +
 +#if ! defined (yyoverflow) || defined (YYERROR_VERBOSE)
 +
 +/* The parser invokes alloca or malloc; define the necessary symbols.  */
 +
 +# if YYSTACK_USE_ALLOCA
 +#  define YYSTACK_ALLOC alloca
 +#  define YYSIZE_T YYSTD (size_t)
 +# else
 +#  ifndef YYSTACK_USE_ALLOCA
 +#   if defined (alloca) || defined (_ALLOCA_H)
 +#    define YYSTACK_ALLOC alloca
 +#    define YYSIZE_T YYSTD (size_t)
 +#   else
 +#    ifdef __GNUC__
 +#     define YYSTACK_ALLOC __builtin_alloca
 +#    endif
 +#   endif
 +#  endif
 +# endif
 +
 +# ifdef YYSTACK_ALLOC
 +   /* Pacify GCC's `empty if-body' warning. */
 +#  define YYSTACK_FREE(Ptr) do { /* empty */; } while (0)
 +# else
 +#  ifdef __cplusplus
 +#   include <cstdlib> /* INFRINGES ON USER NAME SPACE */
 +#   define YYSIZE_T std::size_t
 +#  else
 +#   ifdef __STDC__
 +#    include <stdlib.h> /* INFRINGES ON USER NAME SPACE */
 +#    define YYSIZE_T size_t
 +#   endif
 +#  endif
 +#  define YYSTACK_ALLOC YYSTD (malloc)
 +#  define YYSTACK_FREE YYSTD (free)
 +# endif
 +
 +/* A type that is properly aligned for any stack member.  */
 +union yyalloc
 +{
 +  short yyss;
 +  YYSTYPE yyvs;
 +# if YYLSP_NEEDED
 +  YYLTYPE yyls;
 +# endif
 +};
 +
 +/* The size of the maximum gap between one aligned stack and the next.  */
 +# define YYSTACK_GAP_MAX (sizeof (union yyalloc) - 1)
 +
 +/* The size of an array large to enough to hold all stacks, each with
 +   N elements.  */
 +# if YYLSP_NEEDED
 +#  define YYSTACK_BYTES(N) \
 +     ((N) * (sizeof (short) + sizeof (YYSTYPE) + sizeof (YYLTYPE))	\
 +      + 2 * YYSTACK_GAP_MAX)
 +# else
 +#  define YYSTACK_BYTES(N) \
 +     ((N) * (sizeof (short) + sizeof (YYSTYPE))				\
 +      + YYSTACK_GAP_MAX)
 +# endif
 +
 +/* Relocate the TYPE STACK from its old location to the new one.  The
 +   local variables YYSIZE and YYSTACKSIZE give the old and new number of
 +   elements in the stack, and YYPTR gives the new location of the
 +   stack.  Advance YYPTR to a properly aligned location for the next
 +   stack.  */
 +# define YYSTACK_RELOCATE(Type, Stack)					\
 +    do									\
 +      {									\
 +	YYSIZE_T yynewbytes;						\
 +	yymemcpy ((char *) yyptr, (char *) (Stack),			\
 +		  yysize * (YYSIZE_T) sizeof (Type));			\
 +	Stack = &yyptr->Stack;						\
 +	yynewbytes = yystacksize * sizeof (Type) + YYSTACK_GAP_MAX;	\
 +	yyptr += yynewbytes / sizeof (*yyptr);				\
 +      }									\
 +    while (0)
 +
 +#endif /* ! defined (yyoverflow) || defined (YYERROR_VERBOSE) */
 +
 +
 +#if ! defined (YYSIZE_T) && defined (__SIZE_TYPE__)
 +# define YYSIZE_T __SIZE_TYPE__
 +#endif
 +#if ! defined (YYSIZE_T) && defined (size_t)
 +# define YYSIZE_T size_t
 +#endif
 +#if ! defined (YYSIZE_T)
 +# ifdef __cplusplus
 +#  include <cstddef> /* INFRINGES ON USER NAME SPACE */
 +#  define YYSIZE_T std::size_t
 +# else
 +#  ifdef __STDC__
 +#   include <stddef.h> /* INFRINGES ON USER NAME SPACE */
 +#   define YYSIZE_T size_t
 +#  endif
 +# endif
 +#endif
 +#if ! defined (YYSIZE_T)
 +# define YYSIZE_T unsigned int
 +#endif
 +
 +#define yyerrok		(yyerrstatus = 0)
 +#define yyclearin	(yychar = YYEMPTY)
 +#define YYEMPTY		-2
 +#define YYEOF		0
 +#define YYACCEPT	goto yyacceptlab
 +#define YYABORT 	goto yyabortlab
 +#define YYERROR		goto yyerrlab1
 +/* Like YYERROR except do call yyerror.  This remains here temporarily
 +   to ease the transition to the new meaning of YYERROR, for GCC.
 +   Once GCC version 2 has supplanted version 1, this can go.  */
 +#define YYFAIL		goto yyerrlab
 +#define YYRECOVERING()  (!!yyerrstatus)
 +#define YYBACKUP(Token, Value)					\
 +do								\
 +  if (yychar == YYEMPTY && yylen == 1)				\
 +    {								\
 +      yychar = (Token);						\
 +      yylval = (Value);						\
 +      yychar1 = YYTRANSLATE (yychar);				\
 +      YYPOPSTACK;						\
 +      goto yybackup;						\
 +    }								\
 +  else								\
 +    { 								\
 +      yyerror ("syntax error: cannot back up");			\
 +      YYERROR;							\
 +    }								\
 +while (0)
 +
 +#define YYTERROR	1
 +#define YYERRCODE	256
 +
 +
 +/* YYLLOC_DEFAULT -- Compute the default location (before the actions
 +   are run).
 +
 +   When YYLLOC_DEFAULT is run, CURRENT is set the location of the
 +   first token.  By default, to implement support for ranges, extend
 +   its range to the last symbol.  */
 +
 +#ifndef YYLLOC_DEFAULT
 +# define YYLLOC_DEFAULT(Current, Rhs, N)       	\
 +   Current.last_line   = Rhs[N].last_line;	\
 +   Current.last_column = Rhs[N].last_column;
 +#endif
 +
 +
 +/* YYLEX -- calling `yylex' with the right arguments.  */
 +
 +#if YYPURE
 +# if YYLSP_NEEDED
 +#  ifdef YYLEX_PARAM
 +#   define YYLEX		yylex (&yylval, &yylloc, YYLEX_PARAM)
 +#  else
 +#   define YYLEX		yylex (&yylval, &yylloc)
 +#  endif
 +# else /* !YYLSP_NEEDED */
 +#  ifdef YYLEX_PARAM
 +#   define YYLEX		yylex (&yylval, YYLEX_PARAM)
 +#  else
 +#   define YYLEX		yylex (&yylval)
 +#  endif
 +# endif /* !YYLSP_NEEDED */
 +#else /* !YYPURE */
 +# define YYLEX			yylex ()
 +#endif /* !YYPURE */
 +
 +
 +/* Enable debugging if requested.  */
 +#if YYDEBUG
 +
 +# ifndef YYFPRINTF
 +#  ifdef __cplusplus
 +#   include <cstdio>  /* INFRINGES ON USER NAME SPACE */
 +#  else
 +#   include <stdio.h> /* INFRINGES ON USER NAME SPACE */
 +#  endif
 +#  define YYFPRINTF YYSTD (fprintf)
 +# endif
 +
 +# define YYDPRINTF(Args)			\
 +do {						\
 +  if (yydebug)					\
 +    YYFPRINTF Args;				\
 +} while (0)
 +/* Nonzero means print parse trace. [The following comment makes no
 +   sense to me.  Could someone clarify it?  --akim] Since this is
 +   uninitialized, it does not stop multiple parsers from coexisting.
 +   */
 +int yydebug;
 +#else /* !YYDEBUG */
 +# define YYDPRINTF(Args)
 +#endif /* !YYDEBUG */
 +
 +/* YYINITDEPTH -- initial size of the parser's stacks.  */
 +#ifndef	YYINITDEPTH
 +# define YYINITDEPTH 200
 +#endif
 +
 +/* YYMAXDEPTH -- maximum size the stacks can grow to (effective only
 +   if the built-in stack extension method is used).
 +
 +   Do not make this value too large; the results are undefined if
 +   SIZE_MAX < YYSTACK_BYTES (YYMAXDEPTH)
 +   evaluated with infinite-precision integer arithmetic.  */
 +
 +#if YYMAXDEPTH == 0
 +# undef YYMAXDEPTH
 +#endif
 +
 +#ifndef YYMAXDEPTH
 +# define YYMAXDEPTH 10000
 +#endif
 +
 +#if ! defined (yyoverflow) && ! defined (yymemcpy)
 +# if __GNUC__ > 1		/* GNU C and GNU C++ define this.  */
 +#  define yymemcpy __builtin_memcpy
 +# else				/* not GNU C or C++ */
 +
 +/* This is the most reliable way to avoid incompatibilities
 +   in available built-in functions on various systems.  */
 +static void
 +#  if defined (__STDC__) || defined (__cplusplus)
 +yymemcpy (char *yyto, const char *yyfrom, YYSIZE_T yycount)
 +#  else
 +yymemcpy (yyto, yyfrom, yycount)
 +     char *yyto;
 +     const char *yyfrom;
 +     YYSIZE_T yycount;
 +#  endif
 +{
 +  register const char *yyf = yyfrom;
 +  register char *yyt = yyto;
 +  register YYSIZE_T yyi = yycount;
 +
 +  while (yyi-- != 0)
 +    *yyt++ = *yyf++;
 +}
 +# endif
 +#endif
 +
 +#ifdef YYERROR_VERBOSE
 +
 +# ifndef yystrlen
 +#  if defined (__GLIBC__) && defined (_STRING_H)
 +#   define yystrlen strlen
 +#  else
 +/* Return the length of YYSTR.  */
 +static YYSIZE_T
 +#   if defined (__STDC__) || defined (__cplusplus)
 +yystrlen (const char *yystr)
 +#   else
 +yystrlen (yystr)
 +     const char *yystr;
 +#   endif
 +{
 +  register const char *yys = yystr;
 +
 +  while (*yys++ != '\0')
 +    continue;
 +
 +  return yys - yystr - 1;
 +}
 +#  endif
 +# endif
 +
 +# ifndef yystpcpy
 +#  if defined (__GLIBC__) && defined (_STRING_H) && defined (_GNU_SOURCE)
 +#   define yystpcpy stpcpy
 +#  else
 +/* Copy YYSRC to YYDEST, returning the address of the terminating '\0' in
 +   YYDEST.  */
 +static char *
 +#   if defined (__STDC__) || defined (__cplusplus)
 +yystpcpy (char *yydest, const char *yysrc)
 +#   else
 +yystpcpy (yydest, yysrc)
 +     char *yydest;
 +     const char *yysrc;
 +#   endif
 +{
 +  register char *yyd = yydest;
 +  register const char *yys = yysrc;
 +
 +  while ((*yyd++ = *yys++) != '\0')
 +    continue;
 +
 +  return yyd - 1;
 +}
 +#  endif
 +# endif
 +#endif
 +
 +#line 341 "/usr/share/bison/bison.simple"
 +
 +
 +/* The user can define YYPARSE_PARAM as the name of an argument to be passed
 +   into yyparse.  The argument should have type void *.
 +   It should actually point to an object.
 +   Grammar actions can access the variable by casting it
 +   to the proper pointer type.  */
 +
 +#ifdef YYPARSE_PARAM
 +# ifdef __cplusplus
 +#  define YYPARSE_PARAM_ARG void *YYPARSE_PARAM
 +#  define YYPARSE_PARAM_DECL
 +# else /* !__cplusplus */
 +#  define YYPARSE_PARAM_ARG YYPARSE_PARAM
 +#  define YYPARSE_PARAM_DECL void *YYPARSE_PARAM;
 +# endif /* !__cplusplus */
 +#else /* !YYPARSE_PARAM */
 +# define YYPARSE_PARAM_ARG
 +# define YYPARSE_PARAM_DECL
 +#endif /* !YYPARSE_PARAM */
 +
 +/* Prevent warning if -Wstrict-prototypes.  */
 +#ifdef __GNUC__
 +# ifdef YYPARSE_PARAM
 +int yyparse (void *);
 +# else
 +int yyparse (void);
 +# endif
 +#endif
 +
 +/* YY_DECL_VARIABLES -- depending whether we use a pure parser,
 +   variables are global, or local to YYPARSE.  */
 +
 +#define YY_DECL_NON_LSP_VARIABLES			\
 +/* The lookahead symbol.  */				\
 +int yychar;						\
 +							\
 +/* The semantic value of the lookahead symbol. */	\
 +YYSTYPE yylval;						\
 +							\
 +/* Number of parse errors so far.  */			\
 +int yynerrs;
 +
 +#if YYLSP_NEEDED
 +# define YY_DECL_VARIABLES			\
 +YY_DECL_NON_LSP_VARIABLES			\
 +						\
 +/* Location data for the lookahead symbol.  */	\
 +YYLTYPE yylloc;
 +#else
 +# define YY_DECL_VARIABLES			\
 +YY_DECL_NON_LSP_VARIABLES
 +#endif
 +
 +
 +/* If nonreentrant, generate the variables here. */
 +
 +#if !YYPURE
 +YY_DECL_VARIABLES
 +#endif  /* !YYPURE */
 +
 +int
 +yyparse (YYPARSE_PARAM_ARG)
 +     YYPARSE_PARAM_DECL
 +{
 +  /* If reentrant, generate the variables here. */
 +#if YYPURE
 +  YY_DECL_VARIABLES
 +#endif  /* !YYPURE */
 +
 +  register int yystate;
 +  register int yyn;
 +  int yyresult;
 +  /* Number of tokens to shift before error messages enabled.  */
 +  int yyerrstatus;
 +  /* Lookahead token as an internal (translated) token number.  */
 +  int yychar1 = 0;
 +
 +  /* Three stacks and their tools:
 +     `yyss': related to states,
 +     `yyvs': related to semantic values,
 +     `yyls': related to locations.
 +
 +     Refer to the stacks thru separate pointers, to allow yyoverflow
 +     to reallocate them elsewhere.  */
 +
 +  /* The state stack. */
 +  short	yyssa[YYINITDEPTH];
 +  short *yyss = yyssa;
 +  register short *yyssp;
 +
 +  /* The semantic value stack.  */
 +  YYSTYPE yyvsa[YYINITDEPTH];
 +  YYSTYPE *yyvs = yyvsa;
 +  register YYSTYPE *yyvsp;
 +
 +#if YYLSP_NEEDED
 +  /* The location stack.  */
 +  YYLTYPE yylsa[YYINITDEPTH];
 +  YYLTYPE *yyls = yylsa;
 +  YYLTYPE *yylsp;
 +#endif
 +
 +#if YYLSP_NEEDED
 +# define YYPOPSTACK   (yyvsp--, yyssp--, yylsp--)
 +#else
 +# define YYPOPSTACK   (yyvsp--, yyssp--)
 +#endif
 +
 +  YYSIZE_T yystacksize = YYINITDEPTH;
 +
 +
 +  /* The variables used to return semantic value and location from the
 +     action routines.  */
 +  YYSTYPE yyval;
 +#if YYLSP_NEEDED
 +  YYLTYPE yyloc;
 +#endif
 +
 +  /* When reducing, the number of symbols on the RHS of the reduced
 +     rule. */
 +  int yylen;
 +
 +  YYDPRINTF ((stderr, "Starting parse\n"));
 +
 +  yystate = 0;
 +  yyerrstatus = 0;
 +  yynerrs = 0;
 +  yychar = YYEMPTY;		/* Cause a token to be read.  */
 +
 +  /* Initialize stack pointers.
 +     Waste one element of value and location stack
 +     so that they stay on the same level as the state stack.
 +     The wasted elements are never initialized.  */
 +
 +  yyssp = yyss;
 +  yyvsp = yyvs;
 +#if YYLSP_NEEDED
 +  yylsp = yyls;
 +#endif
 +  goto yysetstate;
 +
 +/*------------------------------------------------------------.
 +| yynewstate -- Push a new state, which is found in yystate.  |
 +`------------------------------------------------------------*/
 + yynewstate:
 +  /* In all cases, when you get here, the value and location stacks
 +     have just been pushed. so pushing a state here evens the stacks.
 +     */
 +  yyssp++;
 +
 + yysetstate:
 +  *yyssp = yystate;
 +
 +  if (yyssp >= yyss + yystacksize - 1)
 +    {
 +      /* Get the current used size of the three stacks, in elements.  */
 +      YYSIZE_T yysize = yyssp - yyss + 1;
 +
 +#ifdef yyoverflow
 +      {
 +	/* Give user a chance to reallocate the stack. Use copies of
 +	   these so that the &'s don't force the real ones into
 +	   memory.  */
 +	YYSTYPE *yyvs1 = yyvs;
 +	short *yyss1 = yyss;
 +
 +	/* Each stack pointer address is followed by the size of the
 +	   data in use in that stack, in bytes.  */
 +# if YYLSP_NEEDED
 +	YYLTYPE *yyls1 = yyls;
 +	/* This used to be a conditional around just the two extra args,
 +	   but that might be undefined if yyoverflow is a macro.  */
 +	yyoverflow ("parser stack overflow",
 +		    &yyss1, yysize * sizeof (*yyssp),
 +		    &yyvs1, yysize * sizeof (*yyvsp),
 +		    &yyls1, yysize * sizeof (*yylsp),
 +		    &yystacksize);
 +	yyls = yyls1;
 +# else
 +	yyoverflow ("parser stack overflow",
 +		    &yyss1, yysize * sizeof (*yyssp),
 +		    &yyvs1, yysize * sizeof (*yyvsp),
 +		    &yystacksize);
 +# endif
 +	yyss = yyss1;
 +	yyvs = yyvs1;
 +      }
 +#else /* no yyoverflow */
 +      /* Extend the stack our own way.  */
 +      if (yystacksize >= YYMAXDEPTH)
 +	goto yyoverflowlab;
 +      yystacksize *= 2;
 +      if (yystacksize > YYMAXDEPTH)
 +	yystacksize = YYMAXDEPTH;
 +
 +      {
 +	short *yyss1 = yyss;
 +	union yyalloc *yyptr =
 +	  (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize));
 +	if (! yyptr)
 +	  goto yyoverflowlab;
 +	YYSTACK_RELOCATE (short, yyss);
 +	YYSTACK_RELOCATE (YYSTYPE, yyvs);
 +# if YYLSP_NEEDED
 +	YYSTACK_RELOCATE (YYLTYPE, yyls);
 +# endif
 +# undef YYSTACK_RELOCATE
 +	if (yyss1 != yyssa)
 +	  YYSTACK_FREE (yyss1);
 +      }
 +#endif /* no yyoverflow */
 +
 +      yyssp = yyss + yysize - 1;
 +      yyvsp = yyvs + yysize - 1;
 +#if YYLSP_NEEDED
 +      yylsp = yyls + yysize - 1;
 +#endif
 +
 +      YYDPRINTF ((stderr, "Stack size increased to %lu\n",
 +		  (unsigned long int) yystacksize));
 +
 +      if (yyssp >= yyss + yystacksize - 1)
 +	YYABORT;
 +    }
 +
 +  YYDPRINTF ((stderr, "Entering state %d\n", yystate));
 +
 +  goto yybackup;
 +
 +
 +/*-----------.
 +| yybackup.  |
 +`-----------*/
 +yybackup:
 +
 +/* Do appropriate processing given the current state.  */
 +/* Read a lookahead token if we need one and don't already have one.  */
 +/* yyresume: */
 +
 +  /* First try to decide what to do without reference to lookahead token.  */
 +
 +  yyn = yypact[yystate];
 +  if (yyn == YYFLAG)
 +    goto yydefault;
 +
 +  /* Not known => get a lookahead token if don't already have one.  */
 +
 +  /* yychar is either YYEMPTY or YYEOF
 +     or a valid token in external form.  */
 +
 +  if (yychar == YYEMPTY)
 +    {
 +      YYDPRINTF ((stderr, "Reading a token: "));
 +      yychar = YYLEX;
 +    }
 +
 +  /* Convert token to internal form (in yychar1) for indexing tables with */
 +
 +  if (yychar <= 0)		/* This means end of input. */
 +    {
 +      yychar1 = 0;
 +      yychar = YYEOF;		/* Don't call YYLEX any more */
 +
 +      YYDPRINTF ((stderr, "Now at end of input.\n"));
 +    }
 +  else
 +    {
 +      yychar1 = YYTRANSLATE (yychar);
 +
 +#if YYDEBUG
 +     /* We have to keep this `#if YYDEBUG', since we use variables
 +	which are defined only if `YYDEBUG' is set.  */
 +      if (yydebug)
 +	{
 +	  YYFPRINTF (stderr, "Next token is %d (%s",
 +		     yychar, yytname[yychar1]);
 +	  /* Give the individual parser a way to print the precise
 +	     meaning of a token, for further debugging info.  */
 +# ifdef YYPRINT
 +	  YYPRINT (stderr, yychar, yylval);
 +# endif
 +	  YYFPRINTF (stderr, ")\n");
 +	}
 +#endif
 +    }
 +
 +  yyn += yychar1;
 +  if (yyn < 0 || yyn > YYLAST || yycheck[yyn] != yychar1)
 +    goto yydefault;
 +
 +  yyn = yytable[yyn];
 +
 +  /* yyn is what to do for this token type in this state.
 +     Negative => reduce, -yyn is rule number.
 +     Positive => shift, yyn is new state.
 +       New state is final state => don't bother to shift,
 +       just return success.
 +     0, or most negative number => error.  */
 +
 +  if (yyn < 0)
 +    {
 +      if (yyn == YYFLAG)
 +	goto yyerrlab;
 +      yyn = -yyn;
 +      goto yyreduce;
 +    }
 +  else if (yyn == 0)
 +    goto yyerrlab;
 +
 +  if (yyn == YYFINAL)
 +    YYACCEPT;
 +
 +  /* Shift the lookahead token.  */
 +  YYDPRINTF ((stderr, "Shifting token %d (%s), ",
 +	      yychar, yytname[yychar1]));
 +
 +  /* Discard the token being shifted unless it is eof.  */
 +  if (yychar != YYEOF)
 +    yychar = YYEMPTY;
 +
 +  *++yyvsp = yylval;
 +#if YYLSP_NEEDED
 +  *++yylsp = yylloc;
 +#endif
 +
 +  /* Count tokens shifted since error; after three, turn off error
 +     status.  */
 +  if (yyerrstatus)
 +    yyerrstatus--;
 +
 +  yystate = yyn;
 +  goto yynewstate;
 +
 +
 +/*-----------------------------------------------------------.
 +| yydefault -- do the default action for the current state.  |
 +`-----------------------------------------------------------*/
 +yydefault:
 +  yyn = yydefact[yystate];
 +  if (yyn == 0)
 +    goto yyerrlab;
 +  goto yyreduce;
 +
 +
 +/*-----------------------------.
 +| yyreduce -- Do a reduction.  |
 +`-----------------------------*/
 +yyreduce:
 +  /* yyn is the number of a rule to reduce with.  */
 +  yylen = yyr2[yyn];
 +
 +  /* If YYLEN is nonzero, implement the default value of the action:
 +     `$$ = $1'.
 +
 +     Otherwise, the following line sets YYVAL to the semantic value of
 +     the lookahead token.  This behavior is undocumented and Bison
 +     users should not rely upon it.  Assigning to YYVAL
 +     unconditionally makes the parser a bit smaller, and it avoids a
 +     GCC warning that YYVAL may be used uninitialized.  */
 +  yyval = yyvsp[1-yylen];
 +
 +#if YYLSP_NEEDED
 +  /* Similarly for the default location.  Let the user run additional
 +     commands if for instance locations are ranges.  */
 +  yyloc = yylsp[1-yylen];
 +  YYLLOC_DEFAULT (yyloc, (yylsp - yylen), yylen);
 +#endif
 +
 +#if YYDEBUG
 +  /* We have to keep this `#if YYDEBUG', since we use variables which
 +     are defined only if `YYDEBUG' is set.  */
 +  if (yydebug)
 +    {
 +      int yyi;
 +
 +      YYFPRINTF (stderr, "Reducing via rule %d (line %d), ",
 +		 yyn, yyrline[yyn]);
 +
 +      /* Print the symbols being reduced, and their result.  */
 +      for (yyi = yyprhs[yyn]; yyrhs[yyi] > 0; yyi++)
 +	YYFPRINTF (stderr, "%s ", yytname[yyrhs[yyi]]);
 +      YYFPRINTF (stderr, " -> %s\n", yytname[yyr1[yyn]]);
 +    }
 +#endif
 +
 +  switch (yyn) {
 +
 +case 1:
 +#line 144 "y-src/cccp.y"
 +{ expression_value = yyvsp[0].integer.value; }
 +    break;
 +case 3:
 +#line 150 "y-src/cccp.y"
 +{ if (pedantic)
 +			    pedwarn ("comma operator in operand of `#if'");
 +			  yyval.integer = yyvsp[0].integer; }
 +    break;
 +case 4:
 +#line 157 "y-src/cccp.y"
 +{ yyval.integer.value = - yyvsp[0].integer.value;
 +			  if ((yyval.integer.value & yyvsp[0].integer.value) < 0 && ! yyvsp[0].integer.unsignedp)
 +			    integer_overflow ();
 +			  yyval.integer.unsignedp = yyvsp[0].integer.unsignedp; }
 +    break;
 +case 5:
 +#line 162 "y-src/cccp.y"
 +{ yyval.integer.value = ! yyvsp[0].integer.value;
 +			  yyval.integer.unsignedp = 0; }
 +    break;
 +case 6:
 +#line 165 "y-src/cccp.y"
 +{ yyval.integer = yyvsp[0].integer; }
 +    break;
 +case 7:
 +#line 167 "y-src/cccp.y"
 +{ yyval.integer.value = ~ yyvsp[0].integer.value;
 +			  yyval.integer.unsignedp = yyvsp[0].integer.unsignedp; }
 +    break;
 +case 8:
 +#line 170 "y-src/cccp.y"
 +{ yyval.integer.value = check_assertion (yyvsp[0].name.address, yyvsp[0].name.length,
 +						      0, NULL_PTR);
 +			  yyval.integer.unsignedp = 0; }
 +    break;
 +case 9:
 +#line 174 "y-src/cccp.y"
 +{ keyword_parsing = 1; }
 +    break;
 +case 10:
 +#line 176 "y-src/cccp.y"
 +{ yyval.integer.value = check_assertion (yyvsp[-4].name.address, yyvsp[-4].name.length,
 +						      1, yyvsp[-1].keywords);
 +			  keyword_parsing = 0;
 +			  yyval.integer.unsignedp = 0; }
 +    break;
 +case 11:
 +#line 181 "y-src/cccp.y"
 +{ yyval.integer = yyvsp[-1].integer; }
 +    break;
 +case 12:
 +#line 186 "y-src/cccp.y"
 +{ yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp;
 +			  if (yyval.integer.unsignedp)
 +			    yyval.integer.value = (unsigned long) yyvsp[-2].integer.value * yyvsp[0].integer.value;
 +			  else
 +			    {
 +			      yyval.integer.value = yyvsp[-2].integer.value * yyvsp[0].integer.value;
 +			      if (yyvsp[-2].integer.value
 +				  && (yyval.integer.value / yyvsp[-2].integer.value != yyvsp[0].integer.value
 +				      || (yyval.integer.value & yyvsp[-2].integer.value & yyvsp[0].integer.value) < 0))
 +				integer_overflow ();
 +			    } }
 +    break;
 +case 13:
 +#line 198 "y-src/cccp.y"
 +{ if (yyvsp[0].integer.value == 0)
 +			    {
 +			      error ("division by zero in #if");
 +			      yyvsp[0].integer.value = 1;
 +			    }
 +			  yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp;
 +			  if (yyval.integer.unsignedp)
 +			    yyval.integer.value = (unsigned long) yyvsp[-2].integer.value / yyvsp[0].integer.value;
 +			  else
 +			    {
 +			      yyval.integer.value = yyvsp[-2].integer.value / yyvsp[0].integer.value;
 +			      if ((yyval.integer.value & yyvsp[-2].integer.value & yyvsp[0].integer.value) < 0)
 +				integer_overflow ();
 +			    } }
 +    break;
 +case 14:
 +#line 213 "y-src/cccp.y"
 +{ if (yyvsp[0].integer.value == 0)
 +			    {
 +			      error ("division by zero in #if");
 +			      yyvsp[0].integer.value = 1;
 +			    }
 +			  yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp;
 +			  if (yyval.integer.unsignedp)
 +			    yyval.integer.value = (unsigned long) yyvsp[-2].integer.value % yyvsp[0].integer.value;
 +			  else
 +			    yyval.integer.value = yyvsp[-2].integer.value % yyvsp[0].integer.value; }
 +    break;
 +case 15:
 +#line 224 "y-src/cccp.y"
 +{ yyval.integer.value = yyvsp[-2].integer.value + yyvsp[0].integer.value;
 +			  yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp;
 +			  if (! yyval.integer.unsignedp
 +			      && ! possible_sum_sign (yyvsp[-2].integer.value, yyvsp[0].integer.value,
 +						      yyval.integer.value))
 +			    integer_overflow (); }
 +    break;
 +case 16:
 +#line 231 "y-src/cccp.y"
 +{ yyval.integer.value = yyvsp[-2].integer.value - yyvsp[0].integer.value;
 +			  yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp;
 +			  if (! yyval.integer.unsignedp
 +			      && ! possible_sum_sign (yyval.integer.value, yyvsp[0].integer.value,
 +						      yyvsp[-2].integer.value))
 +			    integer_overflow (); }
 +    break;
 +case 17:
 +#line 238 "y-src/cccp.y"
 +{ yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp;
 +			  if (yyvsp[0].integer.value < 0 && ! yyvsp[0].integer.unsignedp)
 +			    yyval.integer.value = right_shift (&yyvsp[-2].integer, -yyvsp[0].integer.value);
 +			  else
 +			    yyval.integer.value = left_shift (&yyvsp[-2].integer, yyvsp[0].integer.value); }
 +    break;
 +case 18:
 +#line 244 "y-src/cccp.y"
 +{ yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp;
 +			  if (yyvsp[0].integer.value < 0 && ! yyvsp[0].integer.unsignedp)
 +			    yyval.integer.value = left_shift (&yyvsp[-2].integer, -yyvsp[0].integer.value);
 +			  else
 +			    yyval.integer.value = right_shift (&yyvsp[-2].integer, yyvsp[0].integer.value); }
 +    break;
 +case 19:
 +#line 250 "y-src/cccp.y"
 +{ yyval.integer.value = (yyvsp[-2].integer.value == yyvsp[0].integer.value);
 +			  yyval.integer.unsignedp = 0; }
 +    break;
 +case 20:
 +#line 253 "y-src/cccp.y"
 +{ yyval.integer.value = (yyvsp[-2].integer.value != yyvsp[0].integer.value);
 +			  yyval.integer.unsignedp = 0; }
 +    break;
 +case 21:
 +#line 256 "y-src/cccp.y"
 +{ yyval.integer.unsignedp = 0;
 +			  if (yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp)
 +			    yyval.integer.value = (unsigned long) yyvsp[-2].integer.value <= yyvsp[0].integer.value;
 +			  else
 +			    yyval.integer.value = yyvsp[-2].integer.value <= yyvsp[0].integer.value; }
 +    break;
 +case 22:
 +#line 262 "y-src/cccp.y"
 +{ yyval.integer.unsignedp = 0;
 +			  if (yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp)
 +			    yyval.integer.value = (unsigned long) yyvsp[-2].integer.value >= yyvsp[0].integer.value;
 +			  else
 +			    yyval.integer.value = yyvsp[-2].integer.value >= yyvsp[0].integer.value; }
 +    break;
 +case 23:
 +#line 268 "y-src/cccp.y"
 +{ yyval.integer.unsignedp = 0;
 +			  if (yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp)
 +			    yyval.integer.value = (unsigned long) yyvsp[-2].integer.value < yyvsp[0].integer.value;
 +			  else
 +			    yyval.integer.value = yyvsp[-2].integer.value < yyvsp[0].integer.value; }
 +    break;
 +case 24:
 +#line 274 "y-src/cccp.y"
 +{ yyval.integer.unsignedp = 0;
 +			  if (yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp)
 +			    yyval.integer.value = (unsigned long) yyvsp[-2].integer.value > yyvsp[0].integer.value;
 +			  else
 +			    yyval.integer.value = yyvsp[-2].integer.value > yyvsp[0].integer.value; }
 +    break;
 +case 25:
 +#line 280 "y-src/cccp.y"
 +{ yyval.integer.value = yyvsp[-2].integer.value & yyvsp[0].integer.value;
 +			  yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp; }
 +    break;
 +case 26:
 +#line 283 "y-src/cccp.y"
 +{ yyval.integer.value = yyvsp[-2].integer.value ^ yyvsp[0].integer.value;
 +			  yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp; }
 +    break;
 +case 27:
 +#line 286 "y-src/cccp.y"
 +{ yyval.integer.value = yyvsp[-2].integer.value | yyvsp[0].integer.value;
 +			  yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp; }
 +    break;
 +case 28:
 +#line 289 "y-src/cccp.y"
 +{ yyval.integer.value = (yyvsp[-2].integer.value && yyvsp[0].integer.value);
 +			  yyval.integer.unsignedp = 0; }
 +    break;
 +case 29:
 +#line 292 "y-src/cccp.y"
 +{ yyval.integer.value = (yyvsp[-2].integer.value || yyvsp[0].integer.value);
 +			  yyval.integer.unsignedp = 0; }
 +    break;
 +case 30:
 +#line 295 "y-src/cccp.y"
 +{ yyval.integer.value = yyvsp[-4].integer.value ? yyvsp[-2].integer.value : yyvsp[0].integer.value;
 +			  yyval.integer.unsignedp = yyvsp[-2].integer.unsignedp || yyvsp[0].integer.unsignedp; }
 +    break;
 +case 31:
 +#line 298 "y-src/cccp.y"
 +{ yyval.integer = yylval.integer; }
 +    break;
 +case 32:
 +#line 300 "y-src/cccp.y"
 +{ yyval.integer = yylval.integer; }
 +    break;
 +case 33:
 +#line 302 "y-src/cccp.y"
 +{ yyval.integer.value = 0;
 +			  yyval.integer.unsignedp = 0; }
 +    break;
 +case 34:
 +#line 307 "y-src/cccp.y"
 +{ yyval.keywords = 0; }
 +    break;
 +case 35:
 +#line 309 "y-src/cccp.y"
 +{ struct arglist *temp;
 +			  yyval.keywords = (struct arglist *) xmalloc (sizeof (struct arglist));
 +			  yyval.keywords->next = yyvsp[-2].keywords;
 +			  yyval.keywords->name = (U_CHAR *) "(";
 +			  yyval.keywords->length = 1;
 +			  temp = yyval.keywords;
 +			  while (temp != 0 && temp->next != 0)
 +			    temp = temp->next;
 +			  temp->next = (struct arglist *) xmalloc (sizeof (struct arglist));
 +			  temp->next->next = yyvsp[0].keywords;
 +			  temp->next->name = (U_CHAR *) ")";
 +			  temp->next->length = 1; }
 +    break;
 +case 36:
 +#line 322 "y-src/cccp.y"
 +{ yyval.keywords = (struct arglist *) xmalloc (sizeof (struct arglist));
 +			  yyval.keywords->name = yyvsp[-1].name.address;
 +			  yyval.keywords->length = yyvsp[-1].name.length;
 +			  yyval.keywords->next = yyvsp[0].keywords; }
 +    break;
 +}
 +
 +#line 727 "/usr/share/bison/bison.simple"
 +
 +
 +  yyvsp -= yylen;
 +  yyssp -= yylen;
 +#if YYLSP_NEEDED
 +  yylsp -= yylen;
 +#endif
 +
 +#if YYDEBUG
 +  if (yydebug)
 +    {
 +      short *yyssp1 = yyss - 1;
 +      YYFPRINTF (stderr, "state stack now");
 +      while (yyssp1 != yyssp)
 +	YYFPRINTF (stderr, " %d", *++yyssp1);
 +      YYFPRINTF (stderr, "\n");
 +    }
 +#endif
 +
 +  *++yyvsp = yyval;
 +#if YYLSP_NEEDED
 +  *++yylsp = yyloc;
 +#endif
 +
 +  /* Now `shift' the result of the reduction.  Determine what state
 +     that goes to, based on the state we popped back to and the rule
 +     number reduced by.  */
 +
 +  yyn = yyr1[yyn];
 +
 +  yystate = yypgoto[yyn - YYNTBASE] + *yyssp;
 +  if (yystate >= 0 && yystate <= YYLAST && yycheck[yystate] == *yyssp)
 +    yystate = yytable[yystate];
 +  else
 +    yystate = yydefgoto[yyn - YYNTBASE];
 +
 +  goto yynewstate;
 +
 +
 +/*------------------------------------.
 +| yyerrlab -- here on detecting error |
 +`------------------------------------*/
 +yyerrlab:
 +  /* If not already recovering from an error, report this error.  */
 +  if (!yyerrstatus)
 +    {
 +      ++yynerrs;
 +
 +#ifdef YYERROR_VERBOSE
 +      yyn = yypact[yystate];
 +
 +      if (yyn > YYFLAG && yyn < YYLAST)
 +	{
 +	  YYSIZE_T yysize = 0;
 +	  char *yymsg;
 +	  int yyx, yycount;
 +
 +	  yycount = 0;
 +	  /* Start YYX at -YYN if negative to avoid negative indexes in
 +	     YYCHECK.  */
 +	  for (yyx = yyn < 0 ? -yyn : 0;
 +	       yyx < (int) (sizeof (yytname) / sizeof (char *)); yyx++)
 +	    if (yycheck[yyx + yyn] == yyx)
 +	      yysize += yystrlen (yytname[yyx]) + 15, yycount++;
 +	  yysize += yystrlen ("parse error, unexpected ") + 1;
 +	  yysize += yystrlen (yytname[YYTRANSLATE (yychar)]);
 +	  yymsg = (char *) YYSTACK_ALLOC (yysize);
 +	  if (yymsg != 0)
 +	    {
 +	      char *yyp = yystpcpy (yymsg, "parse error, unexpected ");
 +	      yyp = yystpcpy (yyp, yytname[YYTRANSLATE (yychar)]);
 +
 +	      if (yycount < 5)
 +		{
 +		  yycount = 0;
 +		  for (yyx = yyn < 0 ? -yyn : 0;
 +		       yyx < (int) (sizeof (yytname) / sizeof (char *));
 +		       yyx++)
 +		    if (yycheck[yyx + yyn] == yyx)
 +		      {
 +			const char *yyq = ! yycount ? ", expecting " : " or ";
 +			yyp = yystpcpy (yyp, yyq);
 +			yyp = yystpcpy (yyp, yytname[yyx]);
 +			yycount++;
 +		      }
 +		}
 +	      yyerror (yymsg);
 +	      YYSTACK_FREE (yymsg);
 +	    }
 +	  else
 +	    yyerror ("parse error; also virtual memory exhausted");
 +	}
 +      else
 +#endif /* defined (YYERROR_VERBOSE) */
 +	yyerror ("parse error");
 +    }
 +  goto yyerrlab1;
 +
 +
 +/*--------------------------------------------------.
 +| yyerrlab1 -- error raised explicitly by an action |
 +`--------------------------------------------------*/
 +yyerrlab1:
 +  if (yyerrstatus == 3)
 +    {
 +      /* If just tried and failed to reuse lookahead token after an
 +	 error, discard it.  */
 +
 +      /* return failure if at end of input */
 +      if (yychar == YYEOF)
 +	YYABORT;
 +      YYDPRINTF ((stderr, "Discarding token %d (%s).\n",
 +		  yychar, yytname[yychar1]));
 +      yychar = YYEMPTY;
 +    }
 +
 +  /* Else will try to reuse lookahead token after shifting the error
 +     token.  */
 +
 +  yyerrstatus = 3;		/* Each real token shifted decrements this */
 +
 +  goto yyerrhandle;
 +
 +
 +/*-------------------------------------------------------------------.
 +| yyerrdefault -- current state does not do anything special for the |
 +| error token.                                                       |
 +`-------------------------------------------------------------------*/
 +yyerrdefault:
 +#if 0
 +  /* This is wrong; only states that explicitly want error tokens
 +     should shift them.  */
 +
 +  /* If its default is to accept any token, ok.  Otherwise pop it.  */
 +  yyn = yydefact[yystate];
 +  if (yyn)
 +    goto yydefault;
 +#endif
 +
 +
 +/*---------------------------------------------------------------.
 +| yyerrpop -- pop the current state because it cannot handle the |
 +| error token                                                    |
 +`---------------------------------------------------------------*/
 +yyerrpop:
 +  if (yyssp == yyss)
 +    YYABORT;
 +  yyvsp--;
 +  yystate = *--yyssp;
 +#if YYLSP_NEEDED
 +  yylsp--;
 +#endif
 +
 +#if YYDEBUG
 +  if (yydebug)
 +    {
 +      short *yyssp1 = yyss - 1;
 +      YYFPRINTF (stderr, "Error: state stack now");
 +      while (yyssp1 != yyssp)
 +	YYFPRINTF (stderr, " %d", *++yyssp1);
 +      YYFPRINTF (stderr, "\n");
 +    }
 +#endif
 +
 +/*--------------.
 +| yyerrhandle.  |
 +`--------------*/
 +yyerrhandle:
 +  yyn = yypact[yystate];
 +  if (yyn == YYFLAG)
 +    goto yyerrdefault;
 +
 +  yyn += YYTERROR;
 +  if (yyn < 0 || yyn > YYLAST || yycheck[yyn] != YYTERROR)
 +    goto yyerrdefault;
 +
 +  yyn = yytable[yyn];
 +  if (yyn < 0)
 +    {
 +      if (yyn == YYFLAG)
 +	goto yyerrpop;
 +      yyn = -yyn;
 +      goto yyreduce;
 +    }
 +  else if (yyn == 0)
 +    goto yyerrpop;
 +
 +  if (yyn == YYFINAL)
 +    YYACCEPT;
 +
 +  YYDPRINTF ((stderr, "Shifting error token, "));
 +
 +  *++yyvsp = yylval;
 +#if YYLSP_NEEDED
 +  *++yylsp = yylloc;
 +#endif
 +
 +  yystate = yyn;
 +  goto yynewstate;
 +
 +
 +/*-------------------------------------.
 +| yyacceptlab -- YYACCEPT comes here.  |
 +`-------------------------------------*/
 +yyacceptlab:
 +  yyresult = 0;
 +  goto yyreturn;
 +
 +/*-----------------------------------.
 +| yyabortlab -- YYABORT comes here.  |
 +`-----------------------------------*/
 +yyabortlab:
 +  yyresult = 1;
 +  goto yyreturn;
 +
 +/*---------------------------------------------.
 +| yyoverflowab -- parser overflow comes here.  |
 +`---------------------------------------------*/
 +yyoverflowlab:
 +  yyerror ("parser stack overflow");
 +  yyresult = 2;
 +  /* Fall through.  */
 +
 +yyreturn:
 +#ifndef yyoverflow
 +  if (yyss != yyssa)
 +    YYSTACK_FREE (yyss);
 +#endif
 +  return yyresult;
 +}
 +#line 327 "y-src/cccp.y"
 +
 +
 +/* During parsing of a C expression, the pointer to the next character
 +   is in this variable.  */
 +
 +static char *lexptr;
 +
 +/* Take care of parsing a number (anything that starts with a digit).
 +   Set yylval and return the token type; update lexptr.
 +   LEN is the number of characters in it.  */
 +
 +/* maybe needs to actually deal with floating point numbers */
 +
 +int
 +parse_number (olen)
 +     int olen;
 +{
 +  register char *p = lexptr;
 +  register int c;
 +  register unsigned long n = 0, nd, ULONG_MAX_over_base;
 +  register int base = 10;
 +  register int len = olen;
 +  register int overflow = 0;
 +  register int digit, largest_digit = 0;
 +  int spec_long = 0;
 +
 +  for (c = 0; c < len; c++)
 +    if (p[c] == '.') {
 +      /* It's a float since it contains a point.  */
 +      yyerror ("floating point numbers not allowed in #if expressions");
 +      return ERROR;
 +    }
 +
 +  yylval.integer.unsignedp = 0;
 +
 +  if (len >= 3 && (!strncmp (p, "0x", 2) || !strncmp (p, "0X", 2))) {
 +    p += 2;
 +    base = 16;
 +    len -= 2;
 +  }
 +  else if (*p == '0')
 +    base = 8;
 +
 +  ULONG_MAX_over_base = (unsigned long) -1 / base;
 +
 +  for (; len > 0; len--) {
 +    c = *p++;
 +
 +    if (c >= '0' && c <= '9')
 +      digit = c - '0';
 +    else if (base == 16 && c >= 'a' && c <= 'f')
 +      digit = c - 'a' + 10;
 +    else if (base == 16 && c >= 'A' && c <= 'F')
 +      digit = c - 'A' + 10;
 +    else {
 +      /* `l' means long, and `u' means unsigned.  */
 +      while (1) {
 +	if (c == 'l' || c == 'L')
 +	  {
 +	    if (spec_long)
 +	      yyerror ("two `l's in integer constant");
 +	    spec_long = 1;
 +	  }
 +	else if (c == 'u' || c == 'U')
 +	  {
 +	    if (yylval.integer.unsignedp)
 +	      yyerror ("two `u's in integer constant");
 +	    yylval.integer.unsignedp = 1;
 +	  }
 +	else
 +	  break;
 +
 +	if (--len == 0)
 +	  break;
 +	c = *p++;
 +      }
 +      /* Don't look for any more digits after the suffixes.  */
 +      break;
 +    }
 +    if (largest_digit < digit)
 +      largest_digit = digit;
 +    nd = n * base + digit;
 +    overflow |= ULONG_MAX_over_base < n | nd < n;
 +    n = nd;
 +  }
 +
 +  if (len != 0) {
 +    yyerror ("Invalid number in #if expression");
 +    return ERROR;
 +  }
 +
 +  if (base <= largest_digit)
 +    warning ("integer constant contains digits beyond the radix");
 +
 +  if (overflow)
 +    warning ("integer constant out of range");
 +
 +  /* If too big to be signed, consider it unsigned.  */
 +  if ((long) n < 0 && ! yylval.integer.unsignedp)
 +    {
 +      if (base == 10)
 +	warning ("integer constant is so large that it is unsigned");
 +      yylval.integer.unsignedp = 1;
 +    }
 +
 +  lexptr = p;
 +  yylval.integer.value = n;
 +  return INT;
 +}
 +
 +struct token {
 +  char *operator;
 +  int token;
 +};
 +
 +static struct token tokentab2[] = {
 +  {"&&", AND},
 +  {"||", OR},
 +  {"<<", LSH},
 +  {">>", RSH},
 +  {"==", EQUAL},
 +  {"!=", NOTEQUAL},
 +  {"<=", LEQ},
 +  {">=", GEQ},
 +  {"++", ERROR},
 +  {"--", ERROR},
 +  {NULL, ERROR}
 +};
 +
 +/* Read one token, getting characters through lexptr.  */
 +
 +int
 +yylex ()
 +{
 +  register int c;
 +  register int namelen;
 +  register unsigned char *tokstart;
 +  register struct token *toktab;
 +  int wide_flag;
 +
 + retry:
 +
 +  tokstart = (unsigned char *) lexptr;
 +  c = *tokstart;
 +  /* See if it is a special token of length 2.  */
 +  if (! keyword_parsing)
 +    for (toktab = tokentab2; toktab->operator != NULL; toktab++)
 +      if (c == *toktab->operator && tokstart[1] == toktab->operator[1]) {
 +	lexptr += 2;
 +	if (toktab->token == ERROR)
 +	  {
 +	    char *buf = (char *) alloca (40);
 +	    sprintf (buf, "`%s' not allowed in operand of `#if'", toktab->operator);
 +	    yyerror (buf);
 +	  }
 +	return toktab->token;
 +      }
 +
 +  switch (c) {
 +  case 0:
 +    return 0;
 +    
 +  case ' ':
 +  case '\t':
 +  case '\r':
 +  case '\n':
 +    lexptr++;
 +    goto retry;
 +    
 +  case 'L':
 +    /* Capital L may start a wide-string or wide-character constant.  */
 +    if (lexptr[1] == '\'')
 +      {
 +	lexptr++;
 +	wide_flag = 1;
 +	goto char_constant;
 +      }
 +    if (lexptr[1] == '"')
 +      {
 +	lexptr++;
 +	wide_flag = 1;
 +	goto string_constant;
 +      }
 +    break;
 +
 +  case '\'':
 +    wide_flag = 0;
 +  char_constant:
 +    lexptr++;
 +    if (keyword_parsing) {
 +      char *start_ptr = lexptr - 1;
 +      while (1) {
 +	c = *lexptr++;
 +	if (c == '\\')
 +	  c = parse_escape (&lexptr);
 +	else if (c == '\'')
 +	  break;
 +      }
 +      yylval.name.address = tokstart;
 +      yylval.name.length = lexptr - start_ptr;
 +      return NAME;
 +    }
 +
 +    /* This code for reading a character constant
 +       handles multicharacter constants and wide characters.
 +       It is mostly copied from c-lex.c.  */
 +    {
 +      register int result = 0;
 +      register num_chars = 0;
 +      unsigned width = CHAR_TYPE_SIZE;
 +      int max_chars;
 +      char *token_buffer;
 +
 +      if (wide_flag)
 +	{
 +	  width = WCHAR_TYPE_SIZE;
 +#ifdef MULTIBYTE_CHARS
 +	  max_chars = MB_CUR_MAX;
 +#else
 +	  max_chars = 1;
 +#endif
 +	}
 +      else
 +	max_chars = LONG_TYPE_SIZE / width;
 +
 +      token_buffer = (char *) alloca (max_chars + 1);
 +
 +      while (1)
 +	{
 +	  c = *lexptr++;
 +
 +	  if (c == '\'' || c == EOF)
 +	    break;
 +
 +	  if (c == '\\')
 +	    {
 +	      c = parse_escape (&lexptr);
 +	      if (width < HOST_BITS_PER_INT
 +		  && (unsigned) c >= (1 << width))
 +		pedwarn ("escape sequence out of range for character");
 +	    }
 +
 +	  num_chars++;
 +
 +	  /* Merge character into result; ignore excess chars.  */
 +	  if (num_chars < max_chars + 1)
 +	    {
 +	      if (width < HOST_BITS_PER_INT)
 +		result = (result << width) | (c & ((1 << width) - 1));
 +	      else
 +		result = c;
 +	      token_buffer[num_chars - 1] = c;
 +	    }
 +	}
 +
 +      token_buffer[num_chars] = 0;
 +
 +      if (c != '\'')
 +	error ("malformatted character constant");
 +      else if (num_chars == 0)
 +	error ("empty character constant");
 +      else if (num_chars > max_chars)
 +	{
 +	  num_chars = max_chars;
 +	  error ("character constant too long");
 +	}
 +      else if (num_chars != 1 && ! traditional)
 +	warning ("multi-character character constant");
 +
 +      /* If char type is signed, sign-extend the constant.  */
 +      if (! wide_flag)
 +	{
 +	  int num_bits = num_chars * width;
 +
 +	  if (lookup ("__CHAR_UNSIGNED__", sizeof ("__CHAR_UNSIGNED__")-1, -1)
 +	      || ((result >> (num_bits - 1)) & 1) == 0)
 +	    yylval.integer.value
 +	      = result & ((unsigned long) ~0 >> (HOST_BITS_PER_LONG - num_bits));
 +	  else
 +	    yylval.integer.value
 +	      = result | ~((unsigned long) ~0 >> (HOST_BITS_PER_LONG - num_bits));
 +	}
 +      else
 +	{
 +#ifdef MULTIBYTE_CHARS
 +	  /* Set the initial shift state and convert the next sequence.  */
 +	  result = 0;
 +	  /* In all locales L'\0' is zero and mbtowc will return zero,
 +	     so don't use it.  */
 +	  if (num_chars > 1
 +	      || (num_chars == 1 && token_buffer[0] != '\0'))
 +	    {
 +	      wchar_t wc;
 +	      (void) mbtowc (NULL_PTR, NULL_PTR, 0);
 +	      if (mbtowc (& wc, token_buffer, num_chars) == num_chars)
 +		result = wc;
 +	      else
 +		warning ("Ignoring invalid multibyte character");
 +	    }
 +#endif
 +	  yylval.integer.value = result;
 +	}
 +    }
 +
 +    /* This is always a signed type.  */
 +    yylval.integer.unsignedp = 0;
 +    
 +    return CHAR;
 +
 +    /* some of these chars are invalid in constant expressions;
 +       maybe do something about them later */
 +  case '/':
 +  case '+':
 +  case '-':
 +  case '*':
 +  case '%':
 +  case '|':
 +  case '&':
 +  case '^':
 +  case '~':
 +  case '!':
 +  case '@':
 +  case '<':
 +  case '>':
 +  case '[':
 +  case ']':
 +  case '.':
 +  case '?':
 +  case ':':
 +  case '=':
 +  case '{':
 +  case '}':
 +  case ',':
 +  case '#':
 +    if (keyword_parsing)
 +      break;
 +  case '(':
 +  case ')':
 +    lexptr++;
 +    return c;
 +
 +  case '"':
 +  string_constant:
 +    if (keyword_parsing) {
 +      char *start_ptr = lexptr;
 +      lexptr++;
 +      while (1) {
 +	c = *lexptr++;
 +	if (c == '\\')
 +	  c = parse_escape (&lexptr);
 +	else if (c == '"')
 +	  break;
 +      }
 +      yylval.name.address = tokstart;
 +      yylval.name.length = lexptr - start_ptr;
 +      return NAME;
 +    }
 +    yyerror ("string constants not allowed in #if expressions");
 +    return ERROR;
 +  }
 +
 +  if (c >= '0' && c <= '9' && !keyword_parsing) {
 +    /* It's a number */
 +    for (namelen = 0;
 +	 c = tokstart[namelen], is_idchar[c] || c == '.'; 
 +	 namelen++)
 +      ;
 +    return parse_number (namelen);
 +  }
 +
 +  /* It is a name.  See how long it is.  */
 +
 +  if (keyword_parsing) {
 +    for (namelen = 0;; namelen++) {
 +      if (is_hor_space[tokstart[namelen]])
 +	break;
 +      if (tokstart[namelen] == '(' || tokstart[namelen] == ')')
 +	break;
 +      if (tokstart[namelen] == '"' || tokstart[namelen] == '\'')
 +	break;
 +    }
 +  } else {
 +    if (!is_idstart[c]) {
 +      yyerror ("Invalid token in expression");
 +      return ERROR;
 +    }
 +
 +    for (namelen = 0; is_idchar[tokstart[namelen]]; namelen++)
 +      ;
 +  }
 +  
 +  lexptr += namelen;
 +  yylval.name.address = tokstart;
 +  yylval.name.length = namelen;
 +  return NAME;
 +}
 +
 +
 +/* Parse a C escape sequence.  STRING_PTR points to a variable
 +   containing a pointer to the string to parse.  That pointer
 +   is updated past the characters we use.  The value of the
 +   escape sequence is returned.
 +
 +   A negative value means the sequence \ newline was seen,
 +   which is supposed to be equivalent to nothing at all.
 +
 +   If \ is followed by a null character, we return a negative
 +   value and leave the string pointer pointing at the null character.
 +
 +   If \ is followed by 000, we return 0 and leave the string pointer
 +   after the zeros.  A value of 0 does not mean end of string.  */
 +
 +int
 +parse_escape (string_ptr)
 +     char **string_ptr;
 +{
 +  register int c = *(*string_ptr)++;
 +  switch (c)
 +    {
 +    case 'a':
 +      return TARGET_BELL;
 +    case 'b':
 +      return TARGET_BS;
 +    case 'e':
 +    case 'E':
 +      if (pedantic)
 +	pedwarn ("non-ANSI-standard escape sequence, `\\%c'", c);
 +      return 033;
 +    case 'f':
 +      return TARGET_FF;
 +    case 'n':
 +      return TARGET_NEWLINE;
 +    case 'r':
 +      return TARGET_CR;
 +    case 't':
 +      return TARGET_TAB;
 +    case 'v':
 +      return TARGET_VT;
 +    case '\n':
 +      return -2;
 +    case 0:
 +      (*string_ptr)--;
 +      return 0;
 +      
 +    case '0':
 +    case '1':
 +    case '2':
 +    case '3':
 +    case '4':
 +    case '5':
 +    case '6':
 +    case '7':
 +      {
 +	register int i = c - '0';
 +	register int count = 0;
 +	while (++count < 3)
 +	  {
 +	    c = *(*string_ptr)++;
 +	    if (c >= '0' && c <= '7')
 +	      i = (i << 3) + c - '0';
 +	    else
 +	      {
 +		(*string_ptr)--;
 +		break;
 +	      }
 +	  }
 +	if ((i & ~((1 << CHAR_TYPE_SIZE) - 1)) != 0)
 +	  {
 +	    i &= (1 << CHAR_TYPE_SIZE) - 1;
 +	    warning ("octal character constant does not fit in a byte");
 +	  }
 +	return i;
 +      }
 +    case 'x':
 +      {
 +	register unsigned i = 0, overflow = 0, digits_found = 0, digit;
 +	for (;;)
 +	  {
 +	    c = *(*string_ptr)++;
 +	    if (c >= '0' && c <= '9')
 +	      digit = c - '0';
 +	    else if (c >= 'a' && c <= 'f')
 +	      digit = c - 'a' + 10;
 +	    else if (c >= 'A' && c <= 'F')
 +	      digit = c - 'A' + 10;
 +	    else
 +	      {
 +		(*string_ptr)--;
 +		break;
 +	      }
 +	    overflow |= i ^ (i << 4 >> 4);
 +	    i = (i << 4) + digit;
 +	    digits_found = 1;
 +	  }
 +	if (!digits_found)
 +	  yyerror ("\\x used with no following hex digits");
 +	if (overflow | (i & ~((1 << BITS_PER_UNIT) - 1)))
 +	  {
 +	    i &= (1 << BITS_PER_UNIT) - 1;
 +	    warning ("hex character constant does not fit in a byte");
 +	  }
 +	return i;
 +      }
 +    default:
 +      return c;
 +    }
 +}
 +
 +void
 +yyerror (s)
 +     char *s;
 +{
 +  error (s);
 +  longjmp (parse_return_error, 1);
 +}
 +
 +static void
 +integer_overflow ()
 +{
 +  if (pedantic)
 +    pedwarn ("integer overflow in preprocessor expression");
 +}
 +
 +static long
 +left_shift (a, b)
 +     struct constant *a;
 +     unsigned long b;
 +{
 +  if (b >= HOST_BITS_PER_LONG)
 +    {
 +      if (! a->unsignedp && a->value != 0)
 +	integer_overflow ();
 +      return 0;
 +    }
 +  else if (a->unsignedp)
 +    return (unsigned long) a->value << b;
 +  else
 +    {
 +      long l = a->value << b;
 +      if (l >> b != a->value)
 +	integer_overflow ();
 +      return l;
 +    }
 +}
 +
 +static long
 +right_shift (a, b)
 +     struct constant *a;
 +     unsigned long b;
 +{
 +  if (b >= HOST_BITS_PER_LONG)
 +    return a->unsignedp ? 0 : a->value >> (HOST_BITS_PER_LONG - 1);
 +  else if (a->unsignedp)
 +    return (unsigned long) a->value >> b;
 +  else
 +    return a->value >> b;
 +}
 +
 +/* This page contains the entry point to this file.  */
 +
 +/* Parse STRING as an expression, and complain if this fails
 +   to use up all of the contents of STRING.  */
 +/* We do not support C comments.  They should be removed before
 +   this function is called.  */
 +
 +int
 +parse_c_expression (string)
 +     char *string;
 +{
 +  lexptr = string;
 +  
 +  if (lexptr == 0 || *lexptr == 0) {
 +    error ("empty #if expression");
 +    return 0;			/* don't include the #if group */
 +  }
 +
 +  /* if there is some sort of scanning error, just return 0 and assume
 +     the parsing routine has printed an error message somewhere.
 +     there is surely a better thing to do than this.     */
 +  if (setjmp (parse_return_error))
 +    return 0;
 +
 +  if (yyparse ())
 +    return 0;			/* actually this is never reached
 +				   the way things stand. */
 +  if (*lexptr)
 +    error ("Junk after end of expression.");
 +
 +  return expression_value;	/* set by yyparse () */
 +}
 +
 +#ifdef TEST_EXP_READER
 +extern int yydebug;
 +
 +/* Main program for testing purposes.  */
 +int
 +main ()
 +{
 +  int n, c;
 +  char buf[1024];
 +
 +/*
 +  yydebug = 1;
 +*/
 +  initialize_random_junk ();
 +
 +  for (;;) {
 +    printf ("enter expression: ");
 +    n = 0;
 +    while ((buf[n] = getchar ()) != '\n' && buf[n] != EOF)
 +      n++;
 +    if (buf[n] == EOF)
 +      break;
 +    buf[n] = '\0';
 +    printf ("parser returned %d\n", parse_c_expression (buf));
 +  }
 +
 +  return 0;
 +}
 +
 +/* table to tell if char can be part of a C identifier. */
 +unsigned char is_idchar[256];
 +/* table to tell if char can be first char of a c identifier. */
 +unsigned char is_idstart[256];
 +/* table to tell if c is horizontal space.  isspace () thinks that
 +   newline is space; this is not a good idea for this program. */
 +char is_hor_space[256];
 +
 +/*
 + * initialize random junk in the hash table and maybe other places
 + */
 +initialize_random_junk ()
 +{
 +  register int i;
 +
 +  /*
 +   * Set up is_idchar and is_idstart tables.  These should be
 +   * faster than saying (is_alpha (c) || c == '_'), etc.
 +   * Must do set up these things before calling any routines tthat
 +   * refer to them.
 +   */
 +  for (i = 'a'; i <= 'z'; i++) {
 +    ++is_idchar[i - 'a' + 'A'];
 +    ++is_idchar[i];
 +    ++is_idstart[i - 'a' + 'A'];
 +    ++is_idstart[i];
 +  }
 +  for (i = '0'; i <= '9'; i++)
 +    ++is_idchar[i];
 +  ++is_idchar['_'];
 +  ++is_idstart['_'];
 +#if DOLLARS_IN_IDENTIFIERS
 +  ++is_idchar['$'];
 +  ++is_idstart['$'];
 +#endif
 +
 +  /* horizontal space table */
 +  ++is_hor_space[' '];
 +  ++is_hor_space['\t'];
 +}
 +
 +error (msg)
 +{
 +  printf ("error: %s\n", msg);
 +}
 +
 +warning (msg)
 +{
 +  printf ("warning: %s\n", msg);
 +}
 +
 +struct hashnode *
 +lookup (name, len, hash)
 +     char *name;
 +     int len;
 +     int hash;
 +{
 +  return (DEFAULT_SIGNED_CHAR) ? 0 : ((struct hashnode *) -1);
 +}
 +#endif
diff --cc test/manual/etags/y-src/parse.c
index d21af68b9bb,00000000000..f8d836e649d
mode 100644,000000..100644
--- a/test/manual/etags/y-src/parse.c
+++ b/test/manual/etags/y-src/parse.c
@@@ -1,2236 -1,0 +1,2237 @@@
 +/* A Bison parser, made from parse.y
 +   by GNU bison 1.32.  */
 +
 +#define YYBISON 1  /* Identify Bison output.  */
 +
 +# define	NE	257
 +# define	LE	258
 +# define	GE	259
 +# define	NEG	260
 +# define	L_CELL	261
 +# define	L_RANGE	262
 +# define	L_VAR	263
 +# define	L_CONST	264
 +# define	L_FN0	265
 +# define	L_FN1	266
 +# define	L_FN2	267
 +# define	L_FN3	268
 +# define	L_FN4	269
 +# define	L_FNN	270
 +# define	L_FN1R	271
 +# define	L_FN2R	272
 +# define	L_FN3R	273
 +# define	L_FN4R	274
 +# define	L_FNNR	275
 +# define	L_LE	276
 +# define	L_NE	277
 +# define	L_GE	278
 +
 +#line 1 "y-src/parse.y"
 +
- /*	Copyright (C) 1990, 1992-1993, 2016 Free Software Foundation, Inc.
++/*	Copyright (C) 1990, 1992-1993, 2016-2017 Free Software Foundation,
++ *	Inc.
 +
 +This file is part of Oleo, the GNU Spreadsheet.
 +
 +Oleo is free software; you can redistribute it and/or modify
 +it under the terms of the GNU General Public License as published by
 +the Free Software Foundation; either version 2, or (at your option)
 +any later version.
 +
 +Oleo is distributed in the hope that it will be useful,
 +but WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +GNU General Public License for more details.
 +
 +You should have received a copy of the GNU General Public License
 +along with Oleo; see the file COPYING.  If not, write to
 +the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
 +#line 41 "y-src/parse.y"
 +
 +#include "funcdef.h"
 +
 +#include <ctype.h>
 +
 +#define obstack_chunk_alloc ck_malloc
 +#define obstack_chunk_free free
 +#include "obstack.h"
 +#include "sysdef.h"
 +
 +#include "global.h"
 +#include "errors.h"
 +#include "node.h"
 +#include "eval.h"
 +#include "ref.h"
 +
 +int yylex ();
 +#ifdef __STDC__
 +void yyerror (char *);
 +#else
 +void yyerror ();
 +#endif
 +VOIDSTAR parse_hash;
 +extern VOIDSTAR hash_find();
 +
 +/* This table contains a list of the infix single-char functions */
 +unsigned char fnin[] = {
 +	SUM, DIFF, DIV, PROD, MOD, /* AND, OR, */ POW, EQUAL, IF, CONCAT, 0
 +};
 +
 +#define YYSTYPE _y_y_s_t_y_p_e
 +typedef struct node *YYSTYPE;
 +YYSTYPE parse_return;
 +#ifdef __STDC__
 +YYSTYPE make_list (YYSTYPE, YYSTYPE);
 +#else
 +YYSTYPE make_list ();
 +#endif
 +
 +char *instr;
 +int parse_error = 0;
 +extern struct obstack tmp_mem;
 +
 +#ifndef YYSTYPE
 +#define YYSTYPE int
 +#endif
 +#ifndef YYDEBUG
 +# define YYDEBUG 0
 +#endif
 +
 +
 +
 +#define	YYFINAL		131
 +#define	YYFLAG		-32768
 +#define	YYNTBASE	41
 +
 +/* YYTRANSLATE(YYLEX) -- Bison token number corresponding to YYLEX. */
 +#define YYTRANSLATE(x) ((unsigned)(x) <= 278 ? yytranslate[x] : 47)
 +
 +/* YYTRANSLATE[YYLEX] -- Bison token number corresponding to YYLEX. */
 +static const char yytranslate[] =
 +{
 +       0,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,    19,     2,     2,     2,    16,     5,     2,
 +      38,    39,    14,    12,    40,    13,     2,    15,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     4,     2,
 +       8,     6,    10,     3,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,    17,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     2,     2,     2,     2,
 +       2,     2,     2,     2,     2,     2,     1,     7,     9,    11,
 +      18,    20,    21,    22,    23,    24,    25,    26,    27,    28,
 +      29,    30,    31,    32,    33,    34,    35,    36,    37
 +};
 +
 +#if YYDEBUG
 +static const short yyprhs[] =
 +{
 +       0,     0,     2,     4,     6,     8,    12,    17,    24,    33,
 +      44,    49,    54,    59,    66,    73,    82,    91,   100,   109,
 +     114,   120,   124,   128,   132,   136,   140,   144,   148,   152,
 +     156,   160,   164,   168,   172,   175,   178,   182,   186,   189,
 +     191,   195,   197,   199,   201,   205,   207
 +};
 +static const short yyrhs[] =
 +{
 +      42,     0,     1,     0,    23,     0,    46,     0,    24,    38,
 +      39,     0,    25,    38,    42,    39,     0,    26,    38,    42,
 +      40,    42,    39,     0,    27,    38,    42,    40,    42,    40,
 +      42,    39,     0,    28,    38,    42,    40,    42,    40,    42,
 +      40,    42,    39,     0,    29,    38,    43,    39,     0,    30,
 +      38,    21,    39,     0,    30,    38,    22,    39,     0,    31,
 +      38,    21,    40,    42,    39,     0,    31,    38,    22,    40,
 +      42,    39,     0,    31,    38,    21,    40,    42,    40,    42,
 +      39,     0,    31,    38,    22,    40,    42,    40,    42,    39,
 +       0,    32,    38,    21,    40,    42,    40,    42,    39,     0,
 +      32,    38,    22,    40,    42,    40,    42,    39,     0,    34,
 +      38,    45,    39,     0,    42,     3,    42,     4,    42,     0,
 +      42,     5,    42,     0,    42,     8,    42,     0,    42,     9,
 +      42,     0,    42,     6,    42,     0,    42,     7,    42,     0,
 +      42,    10,    42,     0,    42,    11,    42,     0,    42,    12,
 +      42,     0,    42,    13,    42,     0,    42,    14,    42,     0,
 +      42,    15,    42,     0,    42,    16,    42,     0,    42,    17,
 +      42,     0,    13,    42,     0,    19,    42,     0,    38,    42,
 +      39,     0,    38,    42,     1,     0,    38,     1,     0,    42,
 +       0,    43,    40,    42,     0,    21,     0,    42,     0,    44,
 +       0,    45,    40,    44,     0,    20,     0,    22,     0
 +};
 +
 +#endif
 +
 +#if YYDEBUG
 +/* YYRLINE[YYN] -- source line where rule number YYN was defined. */
 +static const short yyrline[] =
 +{
 +       0,    86,    88,    94,    95,    96,    98,   102,   106,   110,
 +     114,   118,   121,   125,   129,   135,   142,   150,   154,   159,
 +     163,   174,   178,   182,   186,   190,   194,   198,   202,   206,
 +     210,   214,   218,   222,   226,   241,   245,   247,   255,   262,
 +     264,   268,   269,   272,   274,   278,   280
 +};
 +#endif
 +
 +
 +#if (YYDEBUG) || defined YYERROR_VERBOSE
 +
 +/* YYTNAME[TOKEN_NUM] -- String name of the token TOKEN_NUM. */
 +static const char *const yytname[] =
 +{
 +  "$", "error", "$undefined.", "'?'", "':'", "'&'", "'='", "NE", "'<'", 
 +  "LE", "'>'", "GE", "'+'", "'-'", "'*'", "'/'", "'%'", "'^'", "NEG", 
 +  "'!'", "L_CELL", "L_RANGE", "L_VAR", "L_CONST", "L_FN0", "L_FN1", 
 +  "L_FN2", "L_FN3", "L_FN4", "L_FNN", "L_FN1R", "L_FN2R", "L_FN3R", 
 +  "L_FN4R", "L_FNNR", "L_LE", "L_NE", "L_GE", "'('", "')'", "','", "line", 
 +  "exp", "exp_list", "range_exp", "range_exp_list", "cell", NULL
 +};
 +#endif
 +
 +/* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */
 +static const short yyr1[] =
 +{
 +       0,    41,    41,    42,    42,    42,    42,    42,    42,    42,
 +      42,    42,    42,    42,    42,    42,    42,    42,    42,    42,
 +      42,    42,    42,    42,    42,    42,    42,    42,    42,    42,
 +      42,    42,    42,    42,    42,    42,    42,    42,    42,    43,
 +      43,    44,    44,    45,    45,    46,    46
 +};
 +
 +/* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */
 +static const short yyr2[] =
 +{
 +       0,     1,     1,     1,     1,     3,     4,     6,     8,    10,
 +       4,     4,     4,     6,     6,     8,     8,     8,     8,     4,
 +       5,     3,     3,     3,     3,     3,     3,     3,     3,     3,
 +       3,     3,     3,     3,     2,     2,     3,     3,     2,     1,
 +       3,     1,     1,     1,     3,     1,     1
 +};
 +
 +/* YYDEFACT[S] -- default rule to reduce with in state S when YYTABLE
 +   doesn't specify something else to do.  Zero means the default is an
 +   error. */
 +static const short yydefact[] =
 +{
 +       0,     2,     0,     0,    45,    46,     3,     0,     0,     0,
 +       0,     0,     0,     0,     0,     0,     0,     0,     1,     4,
 +      34,    35,     0,     0,     0,     0,     0,     0,     0,     0,
 +       0,     0,    38,     0,     0,     0,     0,     0,     0,     0,
 +       0,     0,     0,     0,     0,     0,     0,     0,     5,     0,
 +       0,     0,     0,    39,     0,     0,     0,     0,     0,     0,
 +       0,    41,    42,    43,     0,    37,    36,     0,    21,    24,
 +      25,    22,    23,    26,    27,    28,    29,    30,    31,    32,
 +      33,     6,     0,     0,     0,    10,     0,    11,    12,     0,
 +       0,     0,     0,    19,     0,     0,     0,     0,     0,    40,
 +       0,     0,     0,     0,    44,    20,     7,     0,     0,    13,
 +       0,    14,     0,     0,     0,     0,     0,     0,     0,     0,
 +       0,     8,     0,    15,    16,    17,    18,     0,     9,     0,
 +       0,     0
 +};
 +
 +static const short yydefgoto[] =
 +{
 +     129,    62,    54,    63,    64,    19
 +};
 +
 +static const short yypact[] =
 +{
 +     104,-32768,   486,   486,-32768,-32768,-32768,   -37,   -22,   -16,
 +      10,    12,    14,    29,    43,    47,    50,   124,   537,-32768,
 +  -32768,-32768,    59,   486,   486,   486,   486,   486,     7,     9,
 +      11,   464,-32768,    48,   486,   486,   486,   486,   486,   486,
 +     486,   486,   486,   486,   486,   486,   486,   486,-32768,   332,
 +     173,   209,   224,   537,    54,    60,    61,    64,    66,    69,
 +      71,-32768,   537,-32768,    57,-32768,-32768,   522,    -2,   193,
 +     193,   547,   547,   547,   547,     4,     4,    84,    84,    84,
 +      84,-32768,   486,   486,   486,-32768,   486,-32768,-32768,   486,
 +     486,   486,   486,-32768,   464,   486,   353,   245,   260,   537,
 +      63,   158,   281,   296,-32768,   537,-32768,   486,   486,-32768,
 +     486,-32768,   486,   486,   486,   369,   317,   388,   404,   423,
 +     439,-32768,   486,-32768,-32768,-32768,-32768,   458,-32768,   115,
 +     116,-32768
 +};
 +
 +static const short yypgoto[] =
 +{
 +  -32768,     0,-32768,    24,-32768,-32768
 +};
 +
 +
 +#define	YYLAST		564
 +
 +
 +static const short yytable[] =
 +{
 +      18,    22,    20,    21,    36,    37,    38,    39,    40,    41,
 +      42,    43,    44,    45,    46,    47,    23,    33,    44,    45,
 +      46,    47,    24,    49,    50,    51,    52,    53,    55,    56,
 +      57,    58,    59,    60,    67,    68,    69,    70,    71,    72,
 +      73,    74,    75,    76,    77,    78,    79,    80,    25,    65,
 +      26,    34,    27,    35,    36,    37,    38,    39,    40,    41,
 +      42,    43,    44,    45,    46,    47,    34,    28,    35,    36,
 +      37,    38,    39,    40,    41,    42,    43,    44,    45,    46,
 +      47,    29,    96,    97,    98,    30,    99,    66,    31,   100,
 +     101,   102,   103,    85,    86,   105,    93,    94,    48,    87,
 +      88,    47,   109,   110,    89,     1,    90,   115,   116,    91,
 +     117,    92,   118,   119,   120,   130,   131,     2,   104,     0,
 +       0,     0,   127,     3,     4,    32,     5,     6,     7,     8,
 +       9,    10,    11,    12,    13,    14,    15,     2,    16,     0,
 +       0,     0,    17,     3,     4,     0,     5,     6,     7,     8,
 +       9,    10,    11,    12,    13,    14,    15,     0,    16,     0,
 +       0,    34,    17,    35,    36,    37,    38,    39,    40,    41,
 +      42,    43,    44,    45,    46,    47,    34,     0,    35,    36,
 +      37,    38,    39,    40,    41,    42,    43,    44,    45,    46,
 +      47,     0,     0,     0,     0,     0,     0,   111,   112,-32768,
 +  -32768,    38,    39,    40,    41,    42,    43,    44,    45,    46,
 +      47,     0,    34,    82,    35,    36,    37,    38,    39,    40,
 +      41,    42,    43,    44,    45,    46,    47,    34,     0,    35,
 +      36,    37,    38,    39,    40,    41,    42,    43,    44,    45,
 +      46,    47,     0,     0,     0,     0,     0,     0,    34,    83,
 +      35,    36,    37,    38,    39,    40,    41,    42,    43,    44,
 +      45,    46,    47,    34,    84,    35,    36,    37,    38,    39,
 +      40,    41,    42,    43,    44,    45,    46,    47,     0,     0,
 +       0,     0,     0,     0,    34,   107,    35,    36,    37,    38,
 +      39,    40,    41,    42,    43,    44,    45,    46,    47,    34,
 +     108,    35,    36,    37,    38,    39,    40,    41,    42,    43,
 +      44,    45,    46,    47,     0,     0,     0,     0,     0,     0,
 +      34,   113,    35,    36,    37,    38,    39,    40,    41,    42,
 +      43,    44,    45,    46,    47,    34,   114,    35,    36,    37,
 +      38,    39,    40,    41,    42,    43,    44,    45,    46,    47,
 +       0,     0,     0,     0,     0,     0,    34,   122,    35,    36,
 +      37,    38,    39,    40,    41,    42,    43,    44,    45,    46,
 +      47,    81,    34,     0,    35,    36,    37,    38,    39,    40,
 +      41,    42,    43,    44,    45,    46,    47,     0,     0,     0,
 +       0,    34,   106,    35,    36,    37,    38,    39,    40,    41,
 +      42,    43,    44,    45,    46,    47,     0,    34,   121,    35,
 +      36,    37,    38,    39,    40,    41,    42,    43,    44,    45,
 +      46,    47,     0,     0,     0,     0,    34,   123,    35,    36,
 +      37,    38,    39,    40,    41,    42,    43,    44,    45,    46,
 +      47,     0,    34,   124,    35,    36,    37,    38,    39,    40,
 +      41,    42,    43,    44,    45,    46,    47,     0,     0,     0,
 +       0,    34,   125,    35,    36,    37,    38,    39,    40,    41,
 +      42,    43,    44,    45,    46,    47,     0,     2,   126,     0,
 +       0,     0,     0,     3,     4,    61,     5,     6,     7,     8,
 +       9,    10,    11,    12,    13,    14,    15,   128,    16,     2,
 +       0,     0,    17,     0,     0,     3,     4,     0,     5,     6,
 +       7,     8,     9,    10,    11,    12,    13,    14,    15,     0,
 +      16,     0,     0,     0,    17,    34,    95,    35,    36,    37,
 +      38,    39,    40,    41,    42,    43,    44,    45,    46,    47,
 +      34,     0,    35,    36,    37,    38,    39,    40,    41,    42,
 +      43,    44,    45,    46,    47,-32768,-32768,-32768,-32768,    42,
 +      43,    44,    45,    46,    47
 +};
 +
 +static const short yycheck[] =
 +{
 +       0,    38,     2,     3,     6,     7,     8,     9,    10,    11,
 +      12,    13,    14,    15,    16,    17,    38,    17,    14,    15,
 +      16,    17,    38,    23,    24,    25,    26,    27,    21,    22,
 +      21,    22,    21,    22,    34,    35,    36,    37,    38,    39,
 +      40,    41,    42,    43,    44,    45,    46,    47,    38,     1,
 +      38,     3,    38,     5,     6,     7,     8,     9,    10,    11,
 +      12,    13,    14,    15,    16,    17,     3,    38,     5,     6,
 +       7,     8,     9,    10,    11,    12,    13,    14,    15,    16,
 +      17,    38,    82,    83,    84,    38,    86,    39,    38,    89,
 +      90,    91,    92,    39,    40,    95,    39,    40,    39,    39,
 +      39,    17,    39,    40,    40,     1,    40,   107,   108,    40,
 +     110,    40,   112,   113,   114,     0,     0,    13,    94,    -1,
 +      -1,    -1,   122,    19,    20,     1,    22,    23,    24,    25,
 +      26,    27,    28,    29,    30,    31,    32,    13,    34,    -1,
 +      -1,    -1,    38,    19,    20,    -1,    22,    23,    24,    25,
 +      26,    27,    28,    29,    30,    31,    32,    -1,    34,    -1,
 +      -1,     3,    38,     5,     6,     7,     8,     9,    10,    11,
 +      12,    13,    14,    15,    16,    17,     3,    -1,     5,     6,
 +       7,     8,     9,    10,    11,    12,    13,    14,    15,    16,
 +      17,    -1,    -1,    -1,    -1,    -1,    -1,    39,    40,     6,
 +       7,     8,     9,    10,    11,    12,    13,    14,    15,    16,
 +      17,    -1,     3,    40,     5,     6,     7,     8,     9,    10,
 +      11,    12,    13,    14,    15,    16,    17,     3,    -1,     5,
 +       6,     7,     8,     9,    10,    11,    12,    13,    14,    15,
 +      16,    17,    -1,    -1,    -1,    -1,    -1,    -1,     3,    40,
 +       5,     6,     7,     8,     9,    10,    11,    12,    13,    14,
 +      15,    16,    17,     3,    40,     5,     6,     7,     8,     9,
 +      10,    11,    12,    13,    14,    15,    16,    17,    -1,    -1,
 +      -1,    -1,    -1,    -1,     3,    40,     5,     6,     7,     8,
 +       9,    10,    11,    12,    13,    14,    15,    16,    17,     3,
 +      40,     5,     6,     7,     8,     9,    10,    11,    12,    13,
 +      14,    15,    16,    17,    -1,    -1,    -1,    -1,    -1,    -1,
 +       3,    40,     5,     6,     7,     8,     9,    10,    11,    12,
 +      13,    14,    15,    16,    17,     3,    40,     5,     6,     7,
 +       8,     9,    10,    11,    12,    13,    14,    15,    16,    17,
 +      -1,    -1,    -1,    -1,    -1,    -1,     3,    40,     5,     6,
 +       7,     8,     9,    10,    11,    12,    13,    14,    15,    16,
 +      17,    39,     3,    -1,     5,     6,     7,     8,     9,    10,
 +      11,    12,    13,    14,    15,    16,    17,    -1,    -1,    -1,
 +      -1,     3,    39,     5,     6,     7,     8,     9,    10,    11,
 +      12,    13,    14,    15,    16,    17,    -1,     3,    39,     5,
 +       6,     7,     8,     9,    10,    11,    12,    13,    14,    15,
 +      16,    17,    -1,    -1,    -1,    -1,     3,    39,     5,     6,
 +       7,     8,     9,    10,    11,    12,    13,    14,    15,    16,
 +      17,    -1,     3,    39,     5,     6,     7,     8,     9,    10,
 +      11,    12,    13,    14,    15,    16,    17,    -1,    -1,    -1,
 +      -1,     3,    39,     5,     6,     7,     8,     9,    10,    11,
 +      12,    13,    14,    15,    16,    17,    -1,    13,    39,    -1,
 +      -1,    -1,    -1,    19,    20,    21,    22,    23,    24,    25,
 +      26,    27,    28,    29,    30,    31,    32,    39,    34,    13,
 +      -1,    -1,    38,    -1,    -1,    19,    20,    -1,    22,    23,
 +      24,    25,    26,    27,    28,    29,    30,    31,    32,    -1,
 +      34,    -1,    -1,    -1,    38,     3,     4,     5,     6,     7,
 +       8,     9,    10,    11,    12,    13,    14,    15,    16,    17,
 +       3,    -1,     5,     6,     7,     8,     9,    10,    11,    12,
 +      13,    14,    15,    16,    17,     8,     9,    10,    11,    12,
 +      13,    14,    15,    16,    17
 +};
 +/* -*-C-*-  Note some compilers choke on comments on `#line' lines.  */
 +#line 3 "/usr/share/bison/bison.simple"
 +
 +/* Skeleton output parser for bison,
 +   Copyright (C) 1984, 1989, 1990, 2000, 2001 Free Software Foundation, Inc.
 +
 +   This program is free software; you can redistribute it and/or modify
 +   it under the terms of the GNU General Public License as published by
 +   the Free Software Foundation; either version 2, or (at your option)
 +   any later version.
 +
 +   This program is distributed in the hope that it will be useful,
 +   but WITHOUT ANY WARRANTY; without even the implied warranty of
 +   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +   GNU General Public License for more details.
 +
 +   You should have received a copy of the GNU General Public License
 +   along with this program; if not, write to the Free Software
 +   Foundation, Inc., 59 Temple Place - Suite 330,
 +   Boston, MA 02111-1307, USA.  */
 +
 +/* As a special exception, when this file is copied by Bison into a
 +   Bison output file, you may use that output file without restriction.
 +   This special exception was added by the Free Software Foundation
 +   in version 1.24 of Bison.  */
 +
 +/* This is the parser code that is written into each bison parser when
 +   the %semantic_parser declaration is not specified in the grammar.
 +   It was written by Richard Stallman by simplifying the hairy parser
 +   used when %semantic_parser is specified.  */
 +
 +/* All symbols defined below should begin with yy or YY, to avoid
 +   infringing on user name space.  This should be done even for local
 +   variables, as they might otherwise be expanded by user macros.
 +   There are some unavoidable exceptions within include files to
 +   define necessary library symbols; they are noted "INFRINGES ON
 +   USER NAME SPACE" below.  */
 +
 +#ifdef __cplusplus
 +# define YYSTD(x) std::x
 +#else
 +# define YYSTD(x) x
 +#endif
 +
 +#if ! defined (yyoverflow) || defined (YYERROR_VERBOSE)
 +
 +/* The parser invokes alloca or malloc; define the necessary symbols.  */
 +
 +# if YYSTACK_USE_ALLOCA
 +#  define YYSTACK_ALLOC alloca
 +#  define YYSIZE_T YYSTD (size_t)
 +# else
 +#  ifndef YYSTACK_USE_ALLOCA
 +#   if defined (alloca) || defined (_ALLOCA_H)
 +#    define YYSTACK_ALLOC alloca
 +#    define YYSIZE_T YYSTD (size_t)
 +#   else
 +#    ifdef __GNUC__
 +#     define YYSTACK_ALLOC __builtin_alloca
 +#    endif
 +#   endif
 +#  endif
 +# endif
 +
 +# ifdef YYSTACK_ALLOC
 +   /* Pacify GCC's `empty if-body' warning. */
 +#  define YYSTACK_FREE(Ptr) do { /* empty */; } while (0)
 +# else
 +#  ifdef __cplusplus
 +#   include <cstdlib> /* INFRINGES ON USER NAME SPACE */
 +#   define YYSIZE_T std::size_t
 +#  else
 +#   ifdef __STDC__
 +#    include <stdlib.h> /* INFRINGES ON USER NAME SPACE */
 +#    define YYSIZE_T size_t
 +#   endif
 +#  endif
 +#  define YYSTACK_ALLOC YYSTD (malloc)
 +#  define YYSTACK_FREE YYSTD (free)
 +# endif
 +
 +/* A type that is properly aligned for any stack member.  */
 +union yyalloc
 +{
 +  short yyss;
 +  YYSTYPE yyvs;
 +# if YYLSP_NEEDED
 +  YYLTYPE yyls;
 +# endif
 +};
 +
 +/* The size of the maximum gap between one aligned stack and the next.  */
 +# define YYSTACK_GAP_MAX (sizeof (union yyalloc) - 1)
 +
 +/* The size of an array large to enough to hold all stacks, each with
 +   N elements.  */
 +# if YYLSP_NEEDED
 +#  define YYSTACK_BYTES(N) \
 +     ((N) * (sizeof (short) + sizeof (YYSTYPE) + sizeof (YYLTYPE))	\
 +      + 2 * YYSTACK_GAP_MAX)
 +# else
 +#  define YYSTACK_BYTES(N) \
 +     ((N) * (sizeof (short) + sizeof (YYSTYPE))				\
 +      + YYSTACK_GAP_MAX)
 +# endif
 +
 +/* Relocate the TYPE STACK from its old location to the new one.  The
 +   local variables YYSIZE and YYSTACKSIZE give the old and new number of
 +   elements in the stack, and YYPTR gives the new location of the
 +   stack.  Advance YYPTR to a properly aligned location for the next
 +   stack.  */
 +# define YYSTACK_RELOCATE(Type, Stack)					\
 +    do									\
 +      {									\
 +	YYSIZE_T yynewbytes;						\
 +	yymemcpy ((char *) yyptr, (char *) (Stack),			\
 +		  yysize * (YYSIZE_T) sizeof (Type));			\
 +	Stack = &yyptr->Stack;						\
 +	yynewbytes = yystacksize * sizeof (Type) + YYSTACK_GAP_MAX;	\
 +	yyptr += yynewbytes / sizeof (*yyptr);				\
 +      }									\
 +    while (0)
 +
 +#endif /* ! defined (yyoverflow) || defined (YYERROR_VERBOSE) */
 +
 +
 +#if ! defined (YYSIZE_T) && defined (__SIZE_TYPE__)
 +# define YYSIZE_T __SIZE_TYPE__
 +#endif
 +#if ! defined (YYSIZE_T) && defined (size_t)
 +# define YYSIZE_T size_t
 +#endif
 +#if ! defined (YYSIZE_T)
 +# ifdef __cplusplus
 +#  include <cstddef> /* INFRINGES ON USER NAME SPACE */
 +#  define YYSIZE_T std::size_t
 +# else
 +#  ifdef __STDC__
 +#   include <stddef.h> /* INFRINGES ON USER NAME SPACE */
 +#   define YYSIZE_T size_t
 +#  endif
 +# endif
 +#endif
 +#if ! defined (YYSIZE_T)
 +# define YYSIZE_T unsigned int
 +#endif
 +
 +#define yyerrok		(yyerrstatus = 0)
 +#define yyclearin	(yychar = YYEMPTY)
 +#define YYEMPTY		-2
 +#define YYEOF		0
 +#define YYACCEPT	goto yyacceptlab
 +#define YYABORT 	goto yyabortlab
 +#define YYERROR		goto yyerrlab1
 +/* Like YYERROR except do call yyerror.  This remains here temporarily
 +   to ease the transition to the new meaning of YYERROR, for GCC.
 +   Once GCC version 2 has supplanted version 1, this can go.  */
 +#define YYFAIL		goto yyerrlab
 +#define YYRECOVERING()  (!!yyerrstatus)
 +#define YYBACKUP(Token, Value)					\
 +do								\
 +  if (yychar == YYEMPTY && yylen == 1)				\
 +    {								\
 +      yychar = (Token);						\
 +      yylval = (Value);						\
 +      yychar1 = YYTRANSLATE (yychar);				\
 +      YYPOPSTACK;						\
 +      goto yybackup;						\
 +    }								\
 +  else								\
 +    { 								\
 +      yyerror ("syntax error: cannot back up");			\
 +      YYERROR;							\
 +    }								\
 +while (0)
 +
 +#define YYTERROR	1
 +#define YYERRCODE	256
 +
 +
 +/* YYLLOC_DEFAULT -- Compute the default location (before the actions
 +   are run).
 +
 +   When YYLLOC_DEFAULT is run, CURRENT is set the location of the
 +   first token.  By default, to implement support for ranges, extend
 +   its range to the last symbol.  */
 +
 +#ifndef YYLLOC_DEFAULT
 +# define YYLLOC_DEFAULT(Current, Rhs, N)       	\
 +   Current.last_line   = Rhs[N].last_line;	\
 +   Current.last_column = Rhs[N].last_column;
 +#endif
 +
 +
 +/* YYLEX -- calling `yylex' with the right arguments.  */
 +
 +#if YYPURE
 +# if YYLSP_NEEDED
 +#  ifdef YYLEX_PARAM
 +#   define YYLEX		yylex (&yylval, &yylloc, YYLEX_PARAM)
 +#  else
 +#   define YYLEX		yylex (&yylval, &yylloc)
 +#  endif
 +# else /* !YYLSP_NEEDED */
 +#  ifdef YYLEX_PARAM
 +#   define YYLEX		yylex (&yylval, YYLEX_PARAM)
 +#  else
 +#   define YYLEX		yylex (&yylval)
 +#  endif
 +# endif /* !YYLSP_NEEDED */
 +#else /* !YYPURE */
 +# define YYLEX			yylex ()
 +#endif /* !YYPURE */
 +
 +
 +/* Enable debugging if requested.  */
 +#if YYDEBUG
 +
 +# ifndef YYFPRINTF
 +#  ifdef __cplusplus
 +#   include <cstdio>  /* INFRINGES ON USER NAME SPACE */
 +#  else
 +#   include <stdio.h> /* INFRINGES ON USER NAME SPACE */
 +#  endif
 +#  define YYFPRINTF YYSTD (fprintf)
 +# endif
 +
 +# define YYDPRINTF(Args)			\
 +do {						\
 +  if (yydebug)					\
 +    YYFPRINTF Args;				\
 +} while (0)
 +/* Nonzero means print parse trace. [The following comment makes no
 +   sense to me.  Could someone clarify it?  --akim] Since this is
 +   uninitialized, it does not stop multiple parsers from coexisting.
 +   */
 +int yydebug;
 +#else /* !YYDEBUG */
 +# define YYDPRINTF(Args)
 +#endif /* !YYDEBUG */
 +
 +/* YYINITDEPTH -- initial size of the parser's stacks.  */
 +#ifndef	YYINITDEPTH
 +# define YYINITDEPTH 200
 +#endif
 +
 +/* YYMAXDEPTH -- maximum size the stacks can grow to (effective only
 +   if the built-in stack extension method is used).
 +
 +   Do not make this value too large; the results are undefined if
 +   SIZE_MAX < YYSTACK_BYTES (YYMAXDEPTH)
 +   evaluated with infinite-precision integer arithmetic.  */
 +
 +#if YYMAXDEPTH == 0
 +# undef YYMAXDEPTH
 +#endif
 +
 +#ifndef YYMAXDEPTH
 +# define YYMAXDEPTH 10000
 +#endif
 +
 +#if ! defined (yyoverflow) && ! defined (yymemcpy)
 +# if __GNUC__ > 1		/* GNU C and GNU C++ define this.  */
 +#  define yymemcpy __builtin_memcpy
 +# else				/* not GNU C or C++ */
 +
 +/* This is the most reliable way to avoid incompatibilities
 +   in available built-in functions on various systems.  */
 +static void
 +#  if defined (__STDC__) || defined (__cplusplus)
 +yymemcpy (char *yyto, const char *yyfrom, YYSIZE_T yycount)
 +#  else
 +yymemcpy (yyto, yyfrom, yycount)
 +     char *yyto;
 +     const char *yyfrom;
 +     YYSIZE_T yycount;
 +#  endif
 +{
 +  register const char *yyf = yyfrom;
 +  register char *yyt = yyto;
 +  register YYSIZE_T yyi = yycount;
 +
 +  while (yyi-- != 0)
 +    *yyt++ = *yyf++;
 +}
 +# endif
 +#endif
 +
 +#ifdef YYERROR_VERBOSE
 +
 +# ifndef yystrlen
 +#  if defined (__GLIBC__) && defined (_STRING_H)
 +#   define yystrlen strlen
 +#  else
 +/* Return the length of YYSTR.  */
 +static YYSIZE_T
 +#   if defined (__STDC__) || defined (__cplusplus)
 +yystrlen (const char *yystr)
 +#   else
 +yystrlen (yystr)
 +     const char *yystr;
 +#   endif
 +{
 +  register const char *yys = yystr;
 +
 +  while (*yys++ != '\0')
 +    continue;
 +
 +  return yys - yystr - 1;
 +}
 +#  endif
 +# endif
 +
 +# ifndef yystpcpy
 +#  if defined (__GLIBC__) && defined (_STRING_H) && defined (_GNU_SOURCE)
 +#   define yystpcpy stpcpy
 +#  else
 +/* Copy YYSRC to YYDEST, returning the address of the terminating '\0' in
 +   YYDEST.  */
 +static char *
 +#   if defined (__STDC__) || defined (__cplusplus)
 +yystpcpy (char *yydest, const char *yysrc)
 +#   else
 +yystpcpy (yydest, yysrc)
 +     char *yydest;
 +     const char *yysrc;
 +#   endif
 +{
 +  register char *yyd = yydest;
 +  register const char *yys = yysrc;
 +
 +  while ((*yyd++ = *yys++) != '\0')
 +    continue;
 +
 +  return yyd - 1;
 +}
 +#  endif
 +# endif
 +#endif
 +
 +#line 341 "/usr/share/bison/bison.simple"
 +
 +
 +/* The user can define YYPARSE_PARAM as the name of an argument to be passed
 +   into yyparse.  The argument should have type void *.
 +   It should actually point to an object.
 +   Grammar actions can access the variable by casting it
 +   to the proper pointer type.  */
 +
 +#ifdef YYPARSE_PARAM
 +# ifdef __cplusplus
 +#  define YYPARSE_PARAM_ARG void *YYPARSE_PARAM
 +#  define YYPARSE_PARAM_DECL
 +# else /* !__cplusplus */
 +#  define YYPARSE_PARAM_ARG YYPARSE_PARAM
 +#  define YYPARSE_PARAM_DECL void *YYPARSE_PARAM;
 +# endif /* !__cplusplus */
 +#else /* !YYPARSE_PARAM */
 +# define YYPARSE_PARAM_ARG
 +# define YYPARSE_PARAM_DECL
 +#endif /* !YYPARSE_PARAM */
 +
 +/* Prevent warning if -Wstrict-prototypes.  */
 +#ifdef __GNUC__
 +# ifdef YYPARSE_PARAM
 +int yyparse (void *);
 +# else
 +int yyparse (void);
 +# endif
 +#endif
 +
 +/* YY_DECL_VARIABLES -- depending whether we use a pure parser,
 +   variables are global, or local to YYPARSE.  */
 +
 +#define YY_DECL_NON_LSP_VARIABLES			\
 +/* The lookahead symbol.  */				\
 +int yychar;						\
 +							\
 +/* The semantic value of the lookahead symbol. */	\
 +YYSTYPE yylval;						\
 +							\
 +/* Number of parse errors so far.  */			\
 +int yynerrs;
 +
 +#if YYLSP_NEEDED
 +# define YY_DECL_VARIABLES			\
 +YY_DECL_NON_LSP_VARIABLES			\
 +						\
 +/* Location data for the lookahead symbol.  */	\
 +YYLTYPE yylloc;
 +#else
 +# define YY_DECL_VARIABLES			\
 +YY_DECL_NON_LSP_VARIABLES
 +#endif
 +
 +
 +/* If nonreentrant, generate the variables here. */
 +
 +#if !YYPURE
 +YY_DECL_VARIABLES
 +#endif  /* !YYPURE */
 +
 +int
 +yyparse (YYPARSE_PARAM_ARG)
 +     YYPARSE_PARAM_DECL
 +{
 +  /* If reentrant, generate the variables here. */
 +#if YYPURE
 +  YY_DECL_VARIABLES
 +#endif  /* !YYPURE */
 +
 +  register int yystate;
 +  register int yyn;
 +  int yyresult;
 +  /* Number of tokens to shift before error messages enabled.  */
 +  int yyerrstatus;
 +  /* Lookahead token as an internal (translated) token number.  */
 +  int yychar1 = 0;
 +
 +  /* Three stacks and their tools:
 +     `yyss': related to states,
 +     `yyvs': related to semantic values,
 +     `yyls': related to locations.
 +
 +     Refer to the stacks thru separate pointers, to allow yyoverflow
 +     to reallocate them elsewhere.  */
 +
 +  /* The state stack. */
 +  short	yyssa[YYINITDEPTH];
 +  short *yyss = yyssa;
 +  register short *yyssp;
 +
 +  /* The semantic value stack.  */
 +  YYSTYPE yyvsa[YYINITDEPTH];
 +  YYSTYPE *yyvs = yyvsa;
 +  register YYSTYPE *yyvsp;
 +
 +#if YYLSP_NEEDED
 +  /* The location stack.  */
 +  YYLTYPE yylsa[YYINITDEPTH];
 +  YYLTYPE *yyls = yylsa;
 +  YYLTYPE *yylsp;
 +#endif
 +
 +#if YYLSP_NEEDED
 +# define YYPOPSTACK   (yyvsp--, yyssp--, yylsp--)
 +#else
 +# define YYPOPSTACK   (yyvsp--, yyssp--)
 +#endif
 +
 +  YYSIZE_T yystacksize = YYINITDEPTH;
 +
 +
 +  /* The variables used to return semantic value and location from the
 +     action routines.  */
 +  YYSTYPE yyval;
 +#if YYLSP_NEEDED
 +  YYLTYPE yyloc;
 +#endif
 +
 +  /* When reducing, the number of symbols on the RHS of the reduced
 +     rule. */
 +  int yylen;
 +
 +  YYDPRINTF ((stderr, "Starting parse\n"));
 +
 +  yystate = 0;
 +  yyerrstatus = 0;
 +  yynerrs = 0;
 +  yychar = YYEMPTY;		/* Cause a token to be read.  */
 +
 +  /* Initialize stack pointers.
 +     Waste one element of value and location stack
 +     so that they stay on the same level as the state stack.
 +     The wasted elements are never initialized.  */
 +
 +  yyssp = yyss;
 +  yyvsp = yyvs;
 +#if YYLSP_NEEDED
 +  yylsp = yyls;
 +#endif
 +  goto yysetstate;
 +
 +/*------------------------------------------------------------.
 +| yynewstate -- Push a new state, which is found in yystate.  |
 +`------------------------------------------------------------*/
 + yynewstate:
 +  /* In all cases, when you get here, the value and location stacks
 +     have just been pushed. so pushing a state here evens the stacks.
 +     */
 +  yyssp++;
 +
 + yysetstate:
 +  *yyssp = yystate;
 +
 +  if (yyssp >= yyss + yystacksize - 1)
 +    {
 +      /* Get the current used size of the three stacks, in elements.  */
 +      YYSIZE_T yysize = yyssp - yyss + 1;
 +
 +#ifdef yyoverflow
 +      {
 +	/* Give user a chance to reallocate the stack. Use copies of
 +	   these so that the &'s don't force the real ones into
 +	   memory.  */
 +	YYSTYPE *yyvs1 = yyvs;
 +	short *yyss1 = yyss;
 +
 +	/* Each stack pointer address is followed by the size of the
 +	   data in use in that stack, in bytes.  */
 +# if YYLSP_NEEDED
 +	YYLTYPE *yyls1 = yyls;
 +	/* This used to be a conditional around just the two extra args,
 +	   but that might be undefined if yyoverflow is a macro.  */
 +	yyoverflow ("parser stack overflow",
 +		    &yyss1, yysize * sizeof (*yyssp),
 +		    &yyvs1, yysize * sizeof (*yyvsp),
 +		    &yyls1, yysize * sizeof (*yylsp),
 +		    &yystacksize);
 +	yyls = yyls1;
 +# else
 +	yyoverflow ("parser stack overflow",
 +		    &yyss1, yysize * sizeof (*yyssp),
 +		    &yyvs1, yysize * sizeof (*yyvsp),
 +		    &yystacksize);
 +# endif
 +	yyss = yyss1;
 +	yyvs = yyvs1;
 +      }
 +#else /* no yyoverflow */
 +      /* Extend the stack our own way.  */
 +      if (yystacksize >= YYMAXDEPTH)
 +	goto yyoverflowlab;
 +      yystacksize *= 2;
 +      if (yystacksize > YYMAXDEPTH)
 +	yystacksize = YYMAXDEPTH;
 +
 +      {
 +	short *yyss1 = yyss;
 +	union yyalloc *yyptr =
 +	  (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize));
 +	if (! yyptr)
 +	  goto yyoverflowlab;
 +	YYSTACK_RELOCATE (short, yyss);
 +	YYSTACK_RELOCATE (YYSTYPE, yyvs);
 +# if YYLSP_NEEDED
 +	YYSTACK_RELOCATE (YYLTYPE, yyls);
 +# endif
 +# undef YYSTACK_RELOCATE
 +	if (yyss1 != yyssa)
 +	  YYSTACK_FREE (yyss1);
 +      }
 +#endif /* no yyoverflow */
 +
 +      yyssp = yyss + yysize - 1;
 +      yyvsp = yyvs + yysize - 1;
 +#if YYLSP_NEEDED
 +      yylsp = yyls + yysize - 1;
 +#endif
 +
 +      YYDPRINTF ((stderr, "Stack size increased to %lu\n",
 +		  (unsigned long int) yystacksize));
 +
 +      if (yyssp >= yyss + yystacksize - 1)
 +	YYABORT;
 +    }
 +
 +  YYDPRINTF ((stderr, "Entering state %d\n", yystate));
 +
 +  goto yybackup;
 +
 +
 +/*-----------.
 +| yybackup.  |
 +`-----------*/
 +yybackup:
 +
 +/* Do appropriate processing given the current state.  */
 +/* Read a lookahead token if we need one and don't already have one.  */
 +/* yyresume: */
 +
 +  /* First try to decide what to do without reference to lookahead token.  */
 +
 +  yyn = yypact[yystate];
 +  if (yyn == YYFLAG)
 +    goto yydefault;
 +
 +  /* Not known => get a lookahead token if don't already have one.  */
 +
 +  /* yychar is either YYEMPTY or YYEOF
 +     or a valid token in external form.  */
 +
 +  if (yychar == YYEMPTY)
 +    {
 +      YYDPRINTF ((stderr, "Reading a token: "));
 +      yychar = YYLEX;
 +    }
 +
 +  /* Convert token to internal form (in yychar1) for indexing tables with */
 +
 +  if (yychar <= 0)		/* This means end of input. */
 +    {
 +      yychar1 = 0;
 +      yychar = YYEOF;		/* Don't call YYLEX any more */
 +
 +      YYDPRINTF ((stderr, "Now at end of input.\n"));
 +    }
 +  else
 +    {
 +      yychar1 = YYTRANSLATE (yychar);
 +
 +#if YYDEBUG
 +     /* We have to keep this `#if YYDEBUG', since we use variables
 +	which are defined only if `YYDEBUG' is set.  */
 +      if (yydebug)
 +	{
 +	  YYFPRINTF (stderr, "Next token is %d (%s",
 +		     yychar, yytname[yychar1]);
 +	  /* Give the individual parser a way to print the precise
 +	     meaning of a token, for further debugging info.  */
 +# ifdef YYPRINT
 +	  YYPRINT (stderr, yychar, yylval);
 +# endif
 +	  YYFPRINTF (stderr, ")\n");
 +	}
 +#endif
 +    }
 +
 +  yyn += yychar1;
 +  if (yyn < 0 || yyn > YYLAST || yycheck[yyn] != yychar1)
 +    goto yydefault;
 +
 +  yyn = yytable[yyn];
 +
 +  /* yyn is what to do for this token type in this state.
 +     Negative => reduce, -yyn is rule number.
 +     Positive => shift, yyn is new state.
 +       New state is final state => don't bother to shift,
 +       just return success.
 +     0, or most negative number => error.  */
 +
 +  if (yyn < 0)
 +    {
 +      if (yyn == YYFLAG)
 +	goto yyerrlab;
 +      yyn = -yyn;
 +      goto yyreduce;
 +    }
 +  else if (yyn == 0)
 +    goto yyerrlab;
 +
 +  if (yyn == YYFINAL)
 +    YYACCEPT;
 +
 +  /* Shift the lookahead token.  */
 +  YYDPRINTF ((stderr, "Shifting token %d (%s), ",
 +	      yychar, yytname[yychar1]));
 +
 +  /* Discard the token being shifted unless it is eof.  */
 +  if (yychar != YYEOF)
 +    yychar = YYEMPTY;
 +
 +  *++yyvsp = yylval;
 +#if YYLSP_NEEDED
 +  *++yylsp = yylloc;
 +#endif
 +
 +  /* Count tokens shifted since error; after three, turn off error
 +     status.  */
 +  if (yyerrstatus)
 +    yyerrstatus--;
 +
 +  yystate = yyn;
 +  goto yynewstate;
 +
 +
 +/*-----------------------------------------------------------.
 +| yydefault -- do the default action for the current state.  |
 +`-----------------------------------------------------------*/
 +yydefault:
 +  yyn = yydefact[yystate];
 +  if (yyn == 0)
 +    goto yyerrlab;
 +  goto yyreduce;
 +
 +
 +/*-----------------------------.
 +| yyreduce -- Do a reduction.  |
 +`-----------------------------*/
 +yyreduce:
 +  /* yyn is the number of a rule to reduce with.  */
 +  yylen = yyr2[yyn];
 +
 +  /* If YYLEN is nonzero, implement the default value of the action:
 +     `$$ = $1'.
 +
 +     Otherwise, the following line sets YYVAL to the semantic value of
 +     the lookahead token.  This behavior is undocumented and Bison
 +     users should not rely upon it.  Assigning to YYVAL
 +     unconditionally makes the parser a bit smaller, and it avoids a
 +     GCC warning that YYVAL may be used uninitialized.  */
 +  yyval = yyvsp[1-yylen];
 +
 +#if YYLSP_NEEDED
 +  /* Similarly for the default location.  Let the user run additional
 +     commands if for instance locations are ranges.  */
 +  yyloc = yylsp[1-yylen];
 +  YYLLOC_DEFAULT (yyloc, (yylsp - yylen), yylen);
 +#endif
 +
 +#if YYDEBUG
 +  /* We have to keep this `#if YYDEBUG', since we use variables which
 +     are defined only if `YYDEBUG' is set.  */
 +  if (yydebug)
 +    {
 +      int yyi;
 +
 +      YYFPRINTF (stderr, "Reducing via rule %d (line %d), ",
 +		 yyn, yyrline[yyn]);
 +
 +      /* Print the symbols being reduced, and their result.  */
 +      for (yyi = yyprhs[yyn]; yyrhs[yyi] > 0; yyi++)
 +	YYFPRINTF (stderr, "%s ", yytname[yyrhs[yyi]]);
 +      YYFPRINTF (stderr, " -> %s\n", yytname[yyr1[yyn]]);
 +    }
 +#endif
 +
 +  switch (yyn) {
 +
 +case 1:
 +#line 87 "y-src/parse.y"
 +{ parse_return=yyvsp[0]; }
 +    break;
 +case 2:
 +#line 88 "y-src/parse.y"
 +{
 +		if(!parse_error)
 +			parse_error=PARSE_ERR;
 +		parse_return=0; }
 +    break;
 +case 5:
 +#line 96 "y-src/parse.y"
 +{
 +		yyval=yyvsp[-2]; }
 +    break;
 +case 6:
 +#line 98 "y-src/parse.y"
 +{
 +		(yyvsp[-3])->n_x.v_subs[0]=yyvsp[-1];
 +		(yyvsp[-3])->n_x.v_subs[1]=(struct node *)0;
 +		yyval=yyvsp[-3]; }
 +    break;
 +case 7:
 +#line 102 "y-src/parse.y"
 +{
 +		(yyvsp[-5])->n_x.v_subs[0]=yyvsp[-3];
 +		(yyvsp[-5])->n_x.v_subs[1]=yyvsp[-1];
 +		yyval=yyvsp[-5]; }
 +    break;
 +case 8:
 +#line 106 "y-src/parse.y"
 +{
 +		(yyvsp[-7])->n_x.v_subs[0]=make_list(yyvsp[-5],yyvsp[-3]);
 + 		(yyvsp[-7])->n_x.v_subs[1]=yyvsp[-1];
 + 		yyval=yyvsp[-7];}
 +    break;
 +case 9:
 +#line 110 "y-src/parse.y"
 +{
 +		(yyvsp[-9])->n_x.v_subs[0]=make_list(yyvsp[-7],yyvsp[-5]);
 + 		(yyvsp[-9])->n_x.v_subs[1]=make_list(yyvsp[-3],yyvsp[-1]);
 + 		yyval=yyvsp[-9];}
 +    break;
 +case 10:
 +#line 114 "y-src/parse.y"
 +{
 +		(yyvsp[-3])->n_x.v_subs[0]=(struct node *)0;
 +		(yyvsp[-3])->n_x.v_subs[1]=yyvsp[-1];
 +		yyval=yyvsp[-3]; }
 +    break;
 +case 11:
 +#line 118 "y-src/parse.y"
 +{
 +		yyvsp[-3]->n_x.v_subs[0]=yyvsp[-1];
 +		yyval=yyvsp[-3]; }
 +    break;
 +case 12:
 +#line 121 "y-src/parse.y"
 +{
 +		yyvsp[-3]->n_x.v_subs[0]=yyvsp[-1];
 +		yyval=yyvsp[-3]; }
 +    break;
 +case 13:
 +#line 125 "y-src/parse.y"
 +{
 +		yyvsp[-5]->n_x.v_subs[0]=yyvsp[-3];
 +		yyvsp[-5]->n_x.v_subs[1]=yyvsp[-1];
 +		yyval=yyvsp[-5]; }
 +    break;
 +case 14:
 +#line 129 "y-src/parse.y"
 +{
 +		yyvsp[-5]->n_x.v_subs[0]=yyvsp[-3];
 +		yyvsp[-5]->n_x.v_subs[1]=yyvsp[-1];
 +		yyval=yyvsp[-5]; }
 +    break;
 +case 15:
 +#line 135 "y-src/parse.y"
 +{
 +		if(yyvsp[-7]->comp_value!=F_INDEX)
 +			parse_error=PARSE_ERR;
 +		yyvsp[-7]->comp_value=F_INDEX2;
 +		yyvsp[-7]->n_x.v_subs[0]=make_list(yyvsp[-5],yyvsp[-3]);
 +		yyvsp[-7]->n_x.v_subs[1]=yyvsp[-1];
 +		yyval=yyvsp[-7]; }
 +    break;
 +case 16:
 +#line 142 "y-src/parse.y"
 +{
 +		if(yyvsp[-7]->comp_value!=F_INDEX)
 +			parse_error=PARSE_ERR;
 +		yyvsp[-7]->comp_value=F_INDEX2;
 +		yyvsp[-7]->n_x.v_subs[0]=make_list(yyvsp[-5],yyvsp[-3]);
 +		yyvsp[-7]->n_x.v_subs[1]=yyvsp[-1];
 +		yyval=yyvsp[-7]; }
 +    break;
 +case 17:
 +#line 150 "y-src/parse.y"
 +{
 +		(yyvsp[-7])->n_x.v_subs[0]=make_list(yyvsp[-5],yyvsp[-3]);
 + 		(yyvsp[-7])->n_x.v_subs[1]=yyvsp[-1];
 + 		yyval=yyvsp[-7];}
 +    break;
 +case 18:
 +#line 154 "y-src/parse.y"
 +{
 +		(yyvsp[-7])->n_x.v_subs[0]=make_list(yyvsp[-5],yyvsp[-3]);
 + 		(yyvsp[-7])->n_x.v_subs[1]=yyvsp[-1];
 + 		yyval=yyvsp[-7];}
 +    break;
 +case 19:
 +#line 159 "y-src/parse.y"
 +{
 +		(yyvsp[-3])->n_x.v_subs[0]=(struct node *)0;
 +		(yyvsp[-3])->n_x.v_subs[1]=yyvsp[-1];
 +		yyval=yyvsp[-3]; }
 +    break;
 +case 20:
 +#line 163 "y-src/parse.y"
 +{
 +		yyvsp[-3]->comp_value=IF;
 +		yyvsp[-3]->n_x.v_subs[0]=yyvsp[-1];
 +		yyvsp[-3]->n_x.v_subs[1]=yyvsp[0];
 +		yyvsp[-1]->n_x.v_subs[0]=yyvsp[-4];
 +		yyvsp[-1]->n_x.v_subs[1]=yyvsp[-2];
 +		yyval=yyvsp[-3]; }
 +    break;
 +case 21:
 +#line 174 "y-src/parse.y"
 +{
 +		yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2];
 +		yyvsp[-1]->n_x.v_subs[1]=yyvsp[0];
 +		yyval = yyvsp[-1]; }
 +    break;
 +case 22:
 +#line 178 "y-src/parse.y"
 +{
 +		yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2];
 +		yyvsp[-1]->n_x.v_subs[1]=yyvsp[0];
 +		yyval = yyvsp[-1]; }
 +    break;
 +case 23:
 +#line 182 "y-src/parse.y"
 +{
 +		yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2];
 +		yyvsp[-1]->n_x.v_subs[1]=yyvsp[0];
 +		yyval = yyvsp[-1]; }
 +    break;
 +case 24:
 +#line 186 "y-src/parse.y"
 +{
 +		yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2];
 +		yyvsp[-1]->n_x.v_subs[1]=yyvsp[0];
 +		yyval = yyvsp[-1]; }
 +    break;
 +case 25:
 +#line 190 "y-src/parse.y"
 +{
 +		yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2];
 +		yyvsp[-1]->n_x.v_subs[1]=yyvsp[0];
 +		yyval = yyvsp[-1]; }
 +    break;
 +case 26:
 +#line 194 "y-src/parse.y"
 +{
 +		yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2];
 +		yyvsp[-1]->n_x.v_subs[1]=yyvsp[0];
 +		yyval = yyvsp[-1]; }
 +    break;
 +case 27:
 +#line 198 "y-src/parse.y"
 +{
 +		yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2];
 +		yyvsp[-1]->n_x.v_subs[1]=yyvsp[0];
 +		yyval = yyvsp[-1]; }
 +    break;
 +case 28:
 +#line 202 "y-src/parse.y"
 +{
 +		yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2];
 +		yyvsp[-1]->n_x.v_subs[1]=yyvsp[0];
 +		yyval = yyvsp[-1]; }
 +    break;
 +case 29:
 +#line 206 "y-src/parse.y"
 +{
 +		yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2];
 +		yyvsp[-1]->n_x.v_subs[1]=yyvsp[0];
 +		yyval = yyvsp[-1]; }
 +    break;
 +case 30:
 +#line 210 "y-src/parse.y"
 +{
 +		yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2];
 +		yyvsp[-1]->n_x.v_subs[1]=yyvsp[0];
 +		yyval = yyvsp[-1]; }
 +    break;
 +case 31:
 +#line 214 "y-src/parse.y"
 +{
 +		yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2];
 +		yyvsp[-1]->n_x.v_subs[1]=yyvsp[0];
 +		yyval = yyvsp[-1]; }
 +    break;
 +case 32:
 +#line 218 "y-src/parse.y"
 +{
 +		yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2];
 +		yyvsp[-1]->n_x.v_subs[1]=yyvsp[0];
 +		yyval = yyvsp[-1]; }
 +    break;
 +case 33:
 +#line 222 "y-src/parse.y"
 +{
 +		yyvsp[-1]->n_x.v_subs[0]=yyvsp[-2];
 +		yyvsp[-1]->n_x.v_subs[1]=yyvsp[0];
 +		yyval = yyvsp[-1]; }
 +    break;
 +case 34:
 +#line 226 "y-src/parse.y"
 +{
 +		if(yyvsp[0]->comp_value==CONST_FLT) {
 +			yyvsp[0]->n_x.v_float= -(yyvsp[0]->n_x.v_float);
 +			/* free($1); */
 +			yyval=yyvsp[0];
 +		} else if(yyvsp[0]->comp_value==CONST_INT) {
 +			yyvsp[0]->n_x.v_int= -(yyvsp[0]->n_x.v_int);
 +			/* free($1); */
 +			yyval=yyvsp[0];
 +		} else {
 +			yyvsp[-1]->comp_value = NEGATE;
 +			yyvsp[-1]->n_x.v_subs[0]=yyvsp[0];
 +			yyvsp[-1]->n_x.v_subs[1]=(struct node *)0;
 +			yyval = yyvsp[-1];
 +		} }
 +    break;
 +case 35:
 +#line 241 "y-src/parse.y"
 +{
 +		yyvsp[-1]->n_x.v_subs[0]=yyvsp[0];
 +		yyvsp[-1]->n_x.v_subs[1]=(struct node *)0;
 +		yyval = yyvsp[-1]; }
 +    break;
 +case 36:
 +#line 246 "y-src/parse.y"
 +{ yyval = yyvsp[-1]; }
 +    break;
 +case 37:
 +#line 247 "y-src/parse.y"
 +{
 +		if(!parse_error)
 +			parse_error=NO_CLOSE;
 +		}
 +    break;
 +case 38:
 +#line 255 "y-src/parse.y"
 +{
 +		if(!parse_error)
 +			parse_error=NO_CLOSE;
 +		}
 +    break;
 +case 39:
 +#line 263 "y-src/parse.y"
 +{ yyval = make_list(yyvsp[0], 0); }
 +    break;
 +case 40:
 +#line 265 "y-src/parse.y"
 +{ yyval = make_list(yyvsp[0], yyvsp[-2]); }
 +    break;
 +case 43:
 +#line 273 "y-src/parse.y"
 +{ yyval=make_list(yyvsp[0], 0); }
 +    break;
 +case 44:
 +#line 275 "y-src/parse.y"
 +{ yyval=make_list(yyvsp[0],yyvsp[-2]); }
 +    break;
 +case 45:
 +#line 279 "y-src/parse.y"
 +{ yyval=yyvsp[0]; }
 +    break;
 +}
 +
 +#line 727 "/usr/share/bison/bison.simple"
 +
 +
 +  yyvsp -= yylen;
 +  yyssp -= yylen;
 +#if YYLSP_NEEDED
 +  yylsp -= yylen;
 +#endif
 +
 +#if YYDEBUG
 +  if (yydebug)
 +    {
 +      short *yyssp1 = yyss - 1;
 +      YYFPRINTF (stderr, "state stack now");
 +      while (yyssp1 != yyssp)
 +	YYFPRINTF (stderr, " %d", *++yyssp1);
 +      YYFPRINTF (stderr, "\n");
 +    }
 +#endif
 +
 +  *++yyvsp = yyval;
 +#if YYLSP_NEEDED
 +  *++yylsp = yyloc;
 +#endif
 +
 +  /* Now `shift' the result of the reduction.  Determine what state
 +     that goes to, based on the state we popped back to and the rule
 +     number reduced by.  */
 +
 +  yyn = yyr1[yyn];
 +
 +  yystate = yypgoto[yyn - YYNTBASE] + *yyssp;
 +  if (yystate >= 0 && yystate <= YYLAST && yycheck[yystate] == *yyssp)
 +    yystate = yytable[yystate];
 +  else
 +    yystate = yydefgoto[yyn - YYNTBASE];
 +
 +  goto yynewstate;
 +
 +
 +/*------------------------------------.
 +| yyerrlab -- here on detecting error |
 +`------------------------------------*/
 +yyerrlab:
 +  /* If not already recovering from an error, report this error.  */
 +  if (!yyerrstatus)
 +    {
 +      ++yynerrs;
 +
 +#ifdef YYERROR_VERBOSE
 +      yyn = yypact[yystate];
 +
 +      if (yyn > YYFLAG && yyn < YYLAST)
 +	{
 +	  YYSIZE_T yysize = 0;
 +	  char *yymsg;
 +	  int yyx, yycount;
 +
 +	  yycount = 0;
 +	  /* Start YYX at -YYN if negative to avoid negative indexes in
 +	     YYCHECK.  */
 +	  for (yyx = yyn < 0 ? -yyn : 0;
 +	       yyx < (int) (sizeof (yytname) / sizeof (char *)); yyx++)
 +	    if (yycheck[yyx + yyn] == yyx)
 +	      yysize += yystrlen (yytname[yyx]) + 15, yycount++;
 +	  yysize += yystrlen ("parse error, unexpected ") + 1;
 +	  yysize += yystrlen (yytname[YYTRANSLATE (yychar)]);
 +	  yymsg = (char *) YYSTACK_ALLOC (yysize);
 +	  if (yymsg != 0)
 +	    {
 +	      char *yyp = yystpcpy (yymsg, "parse error, unexpected ");
 +	      yyp = yystpcpy (yyp, yytname[YYTRANSLATE (yychar)]);
 +
 +	      if (yycount < 5)
 +		{
 +		  yycount = 0;
 +		  for (yyx = yyn < 0 ? -yyn : 0;
 +		       yyx < (int) (sizeof (yytname) / sizeof (char *));
 +		       yyx++)
 +		    if (yycheck[yyx + yyn] == yyx)
 +		      {
 +			const char *yyq = ! yycount ? ", expecting " : " or ";
 +			yyp = yystpcpy (yyp, yyq);
 +			yyp = yystpcpy (yyp, yytname[yyx]);
 +			yycount++;
 +		      }
 +		}
 +	      yyerror (yymsg);
 +	      YYSTACK_FREE (yymsg);
 +	    }
 +	  else
 +	    yyerror ("parse error; also virtual memory exhausted");
 +	}
 +      else
 +#endif /* defined (YYERROR_VERBOSE) */
 +	yyerror ("parse error");
 +    }
 +  goto yyerrlab1;
 +
 +
 +/*--------------------------------------------------.
 +| yyerrlab1 -- error raised explicitly by an action |
 +`--------------------------------------------------*/
 +yyerrlab1:
 +  if (yyerrstatus == 3)
 +    {
 +      /* If just tried and failed to reuse lookahead token after an
 +	 error, discard it.  */
 +
 +      /* return failure if at end of input */
 +      if (yychar == YYEOF)
 +	YYABORT;
 +      YYDPRINTF ((stderr, "Discarding token %d (%s).\n",
 +		  yychar, yytname[yychar1]));
 +      yychar = YYEMPTY;
 +    }
 +
 +  /* Else will try to reuse lookahead token after shifting the error
 +     token.  */
 +
 +  yyerrstatus = 3;		/* Each real token shifted decrements this */
 +
 +  goto yyerrhandle;
 +
 +
 +/*-------------------------------------------------------------------.
 +| yyerrdefault -- current state does not do anything special for the |
 +| error token.                                                       |
 +`-------------------------------------------------------------------*/
 +yyerrdefault:
 +#if 0
 +  /* This is wrong; only states that explicitly want error tokens
 +     should shift them.  */
 +
 +  /* If its default is to accept any token, ok.  Otherwise pop it.  */
 +  yyn = yydefact[yystate];
 +  if (yyn)
 +    goto yydefault;
 +#endif
 +
 +
 +/*---------------------------------------------------------------.
 +| yyerrpop -- pop the current state because it cannot handle the |
 +| error token                                                    |
 +`---------------------------------------------------------------*/
 +yyerrpop:
 +  if (yyssp == yyss)
 +    YYABORT;
 +  yyvsp--;
 +  yystate = *--yyssp;
 +#if YYLSP_NEEDED
 +  yylsp--;
 +#endif
 +
 +#if YYDEBUG
 +  if (yydebug)
 +    {
 +      short *yyssp1 = yyss - 1;
 +      YYFPRINTF (stderr, "Error: state stack now");
 +      while (yyssp1 != yyssp)
 +	YYFPRINTF (stderr, " %d", *++yyssp1);
 +      YYFPRINTF (stderr, "\n");
 +    }
 +#endif
 +
 +/*--------------.
 +| yyerrhandle.  |
 +`--------------*/
 +yyerrhandle:
 +  yyn = yypact[yystate];
 +  if (yyn == YYFLAG)
 +    goto yyerrdefault;
 +
 +  yyn += YYTERROR;
 +  if (yyn < 0 || yyn > YYLAST || yycheck[yyn] != YYTERROR)
 +    goto yyerrdefault;
 +
 +  yyn = yytable[yyn];
 +  if (yyn < 0)
 +    {
 +      if (yyn == YYFLAG)
 +	goto yyerrpop;
 +      yyn = -yyn;
 +      goto yyreduce;
 +    }
 +  else if (yyn == 0)
 +    goto yyerrpop;
 +
 +  if (yyn == YYFINAL)
 +    YYACCEPT;
 +
 +  YYDPRINTF ((stderr, "Shifting error token, "));
 +
 +  *++yyvsp = yylval;
 +#if YYLSP_NEEDED
 +  *++yylsp = yylloc;
 +#endif
 +
 +  yystate = yyn;
 +  goto yynewstate;
 +
 +
 +/*-------------------------------------.
 +| yyacceptlab -- YYACCEPT comes here.  |
 +`-------------------------------------*/
 +yyacceptlab:
 +  yyresult = 0;
 +  goto yyreturn;
 +
 +/*-----------------------------------.
 +| yyabortlab -- YYABORT comes here.  |
 +`-----------------------------------*/
 +yyabortlab:
 +  yyresult = 1;
 +  goto yyreturn;
 +
 +/*---------------------------------------------.
 +| yyoverflowab -- parser overflow comes here.  |
 +`---------------------------------------------*/
 +yyoverflowlab:
 +  yyerror ("parser stack overflow");
 +  yyresult = 2;
 +  /* Fall through.  */
 +
 +yyreturn:
 +#ifndef yyoverflow
 +  if (yyss != yyssa)
 +    YYSTACK_FREE (yyss);
 +#endif
 +  return yyresult;
 +}
 +#line 282 "y-src/parse.y"
 +
 +
 +void
 +yyerror FUN1(char *, s)
 +{
 +	if(!parse_error)
 +		parse_error=PARSE_ERR;
 +}
 +
 +YYSTYPE
 +make_list FUN2(YYSTYPE, car, YYSTYPE, cdr)
 +{
 +	YYSTYPE ret;
 +
 +	ret=(YYSTYPE)obstack_alloc(&tmp_mem,sizeof(*ret));
 +	ret->comp_value = 0;
 +	ret->n_x.v_subs[0]=car;
 +	ret->n_x.v_subs[1]=cdr;
 +	return ret;
 +}
 +
 +#define ERROR -1
 +
 +extern struct node *yylval;
 +
 +#ifdef __STDC__
 +unsigned char parse_cell_or_range (char **,struct rng *);
 +#else
 +unsigned char parse_cell_or_range ();
 +#endif
 +
 +int
 +yylex FUN0()
 +{
 +	int ch;
 +	struct node *new;
 +	int isflt;
 +	char *begin;
 +	char *tmp_str;
 +	unsigned char byte_value;
 +	int n;
 +
 +	/* unsigned char *ptr; */
 +	int nn;
 +	struct function *fp;
 +	int tmp_ch;
 +
 +#ifdef TEST
 +	if(!instr)
 +		return ERROR;
 +#endif
 +	while(isspace(*instr))
 +		instr++;
 +	ch = *instr++;
 +	if(ch=='(' || ch==',' || ch==')')
 +		return ch;
 +
 +	new=(struct node *)obstack_alloc(&tmp_mem,sizeof(struct node));
 +	new->add_byte=0;
 +	new->sub_value=0;
 +	switch(ch) {
 +	case 0:
 +		return 0;
 +
 +	case '0': case '1': case '2': case '3': case '4': case '5': case '6':
 +	case '7': case '8': case '9': case '.':
 +		isflt = (ch=='.');
 +
 +		begin=instr-1;
 +		tmp_str=instr;
 +
 +		while(isdigit(*tmp_str) || (!isflt && *tmp_str=='.' && ++isflt))
 +			tmp_str++;
 +		if(*tmp_str=='e' || *tmp_str=='E') {
 +			isflt=1;
 +			tmp_str++;
 +			if(*tmp_str=='-' || *tmp_str=='+')
 +				tmp_str++;
 +			while(isdigit(*tmp_str))
 +				tmp_str++;
 +		}
 +		if(isflt) {
 +			new->n_x.v_float=astof((char **)(&begin));
 +			byte_value=CONST_FLT;
 +		} else {
 +			new->n_x.v_int=astol((char **)(&begin));
 +			if(begin!=tmp_str) {
 +				begin=instr-1;
 +				new->n_x.v_float=astof((char **)(&begin));
 +				byte_value=CONST_FLT;
 +			} else
 +				byte_value=CONST_INT;
 +		}
 +		ch=L_CONST;
 +		instr=begin;
 +		break;
 +
 +	case '"':
 +		begin=instr;
 +		while(*instr && *instr!='"') {
 +			if(*instr=='\\' && instr[1])
 +				instr++;
 +			instr++;
 +		}
 +		if(!*instr) {
 +			parse_error=NO_QUOTE;
 +			return ERROR;
 +		}
 +		tmp_str=new->n_x.v_string=(char *)ck_malloc(1+instr-begin);
 +		while(begin!=instr) {
 +			unsigned char n;
 +
 +			if(*begin=='\\') {
 +				begin++;
 +				if(begin[0]>='0' && begin[0]<='7') {
 +					if(begin[1]>='0' && begin[1]<='7') {
 +						if(begin[2]>='0' && begin[2]<='7') {
 +							n=(begin[2]-'0') + (010 * (begin[1]-'0')) + ( 0100 * (begin[0]-'0'));
 +							begin+=3;
 +						} else {
 +							n=(begin[1]-'0') + (010 * (begin[0]-'0'));
 +							begin+=2;
 +						}
 +					} else {
 +						n=begin[0]-'0';
 +						begin++;
 +					}
 +				} else
 +					n= *begin++;
 +				*tmp_str++= n;
 +			} else
 +				*tmp_str++= *begin++;
 +		}
 +		*tmp_str='\0';
 +		instr++;
 +		byte_value=CONST_STR;
 +		ch=L_CONST;
 +		break;
 +
 +	case '+':	case '-':
 +
 +	case '*':	case '/':	case '%':	case '&':
 +	/* case '|': */	case '^':	case '=':
 +
 +	case '?':
 +	{
 +		unsigned char *ptr;
 +
 +		for(ptr= fnin;*ptr;ptr++)
 +			if(the_funs[*ptr].fn_str[0]==ch)
 +				break;
 +#ifdef TEST
 +		if(!*ptr)
 +			panic("Can't find fnin[] entry for '%c'",ch);
 +#endif
 +		byte_value= *ptr;
 +	}
 +		break;
 +
 +	case ':':
 +		byte_value=IF;
 +		break;
 +
 +	case '!':
 +	case '<':
 +	case '>':
 +		if(*instr!='=') {
 +			byte_value = (ch=='<') ? LESS : (ch=='>') ? GREATER : NOT;
 +			break;
 +		}
 +		instr++;
 +		byte_value = (ch=='<') ? LESSEQ : (ch=='>') ? GREATEQ : NOTEQUAL;
 +		ch = (ch=='<') ? LE : (ch=='>') ? GE : NE;
 +		break;
 +
 +	case '\'':
 +	case ';':
 +	case '[':
 +	case '\\':
 +	case ']':
 +	case '`':
 +	case '{':
 +	case '}':
 +	case '~':
 +	bad_chr:
 +		parse_error=BAD_CHAR;
 +		return ERROR;
 +
 +	case '#':
 +		begin=instr-1;
 +		while(*instr && (isalnum(*instr) || *instr=='_'))
 +			instr++;
 +		ch= *instr;
 +		*instr=0;
 +		if(!stricmp(begin,tname))
 +			byte_value=F_TRUE;
 +		else if(!stricmp(begin,fname))
 +			byte_value=F_FALSE;
 +		else if(!stricmp(begin,iname) && (begin[4]==0 || !stricmp(begin+4,"inity")))
 +			byte_value=CONST_INF;
 +		else if(!stricmp(begin,mname) ||
 +			!stricmp(begin,"#ninf"))
 +			byte_value=CONST_NINF;
 +		else if(!stricmp(begin,nname) ||
 +			!stricmp(begin,"#nan"))
 +			byte_value=CONST_NAN;
 +		else {
 +			for(n=1;n<=ERR_MAX;n++)
 +				if(!stricmp(begin,ename[n]))
 +					break;
 +			if(n>ERR_MAX)
 +				n=BAD_CHAR;
 +			new->n_x.v_int=n;
 +			byte_value=CONST_ERR;
 +		}
 +		*instr=ch;
 +		ch=L_CONST;
 +		break;
 +
 +	default:
 +		if(!a0 && (ch=='@' || ch=='$'))
 +		   goto bad_chr;
 +
 +		if(a0 && ch=='@') {
 +			begin=instr;
 +			while(*instr && (isalpha(*instr) || isdigit(*instr) || *instr=='_'))
 +				instr++;
 +			n=instr-begin;
 +		} else {
 +			begin=instr-1;
 +			byte_value=parse_cell_or_range(&begin,&(new->n_x.v_rng));
 +			if(byte_value) {
 +				if((byte_value& ~0x3)==R_CELL)
 +					ch=L_CELL;
 +				else
 +					ch=L_RANGE;
 +				instr=begin;
 +				break;
 +			}
 +
 +			while(*instr && (isalpha(*instr) || isdigit(*instr) || *instr=='_'))
 +				instr++;
 +
 +			n=instr-begin;
 +			while(isspace(*instr))
 +				instr++;
 +
 +			if(*instr!='(') {
 +				ch=L_VAR;
 +				byte_value=VAR;
 +				new->n_x.v_var=find_or_make_var(begin,n);
 +				break;
 +			}
 +		}
 +		tmp_ch=begin[n];
 +		begin[n]='\0';
 +		fp=hash_find(parse_hash,begin);
 +		begin[n]=tmp_ch;
 +		byte_value= ERROR;
 +		if(!fp) {
 +			parse_error=BAD_FUNC;
 +			return ERROR;
 +		}
 +
 +		if(fp>=the_funs && fp<=&the_funs[USR1])
 +			byte_value=fp-the_funs;
 +		else {
 +			for(nn=0;nn<n_usr_funs;nn++) {
 +				if(fp>=&usr_funs[nn][0] && fp<=&usr_funs[nn][usr_n_funs[nn]]) {
 +					byte_value=USR1+nn;
 +					new->sub_value=fp-&usr_funs[nn][0];
 +					break;
 +				}
 +			}
 +#ifdef TEST
 +			if(nn==n_usr_funs) {
 +				io_error_msg("Couln't turn fp into a ##");
 +				parse_error=BAD_FUNC;
 +				return ERROR;
 +			}
 +#endif
 +		}
 +
 +		if(fp->fn_argn&X_J)
 +			ch= byte_value==F_IF ? L_FN3 : L_FN2;
 +		else if(fp->fn_argt[0]=='R' || fp->fn_argt[0]=='E')
 +			ch=L_FN1R-1+fp->fn_argn-X_A0;
 +		else
 +			ch=L_FN0 + fp->fn_argn-X_A0;
 +
 +		break;
 +	}
 +	/* new->node_type=ch; */
 +	new->comp_value=byte_value;
 +	yylval=new;
 +	return ch;
 +}
 +
 +/* Return value is
 +	0 if it doesn't look like a cell or a range,
 +	R_CELL if it is a cell (ptr now points past the characters, lr and lc hold the row and col of the cell)
 +	RANGE if it is a range (ptr points past the chars)
 + */
 +unsigned char
 +parse_cell_or_range FUN2(char **,ptr, struct rng *,retp)
 +{
 +	if(a0) {
 +		unsigned tmpc,tmpr;
 +		char *p;
 +		int abz = ROWREL|COLREL;
 +
 +		p= *ptr;
 +		tmpc=0;
 +		if(*p=='$') {
 +			abz-=COLREL;
 +			p++;
 +		}
 +		if(!isalpha(*p))
 +			return 0;
 +		tmpc=str_to_col(&p);
 +		if(tmpc<MIN_COL || tmpc>MAX_COL)
 +			return 0;
 +		if(*p=='$') {
 +			abz-=ROWREL;
 +			p++;
 +		}
 +		if(!isdigit(*p))
 +			return 0;
 +		for(tmpr=0;isdigit(*p);p++)
 +			tmpr=tmpr*10 + *p - '0';
 +
 +		if(tmpr<MIN_ROW || tmpr>MAX_ROW)
 +			return 0;
 +
 +		if(*p==':' || *p=='.') {
 +			unsigned tmpc1,tmpr1;
 +
 +			abz = ((abz&COLREL) ? LCREL : 0)|((abz&ROWREL) ? LRREL : 0)|HRREL|HCREL;
 +			p++;
 +			if(*p=='$') {
 +				abz-=HCREL;
 +				p++;
 +			}
 +			if(!isalpha(*p))
 +				return 0;
 +			tmpc1=str_to_col(&p);
 +			if(tmpc1<MIN_COL || tmpc1>MAX_COL)
 +				return 0;
 +			if(*p=='$') {
 +				abz-=HRREL;
 +				p++;
 +			}
 +			if(!isdigit(*p))
 +				return 0;
 +			for(tmpr1=0;isdigit(*p);p++)
 +				tmpr1=tmpr1*10 + *p - '0';
 +			if(tmpr1<MIN_ROW || tmpr1>MAX_ROW)
 +				return 0;
 +
 +			if(tmpr<tmpr1) {
 +				retp->lr=tmpr;
 +				retp->hr=tmpr1;
 +			} else {
 +				retp->lr=tmpr1;
 +				retp->hr=tmpr;
 +			}
 +			if(tmpc<tmpc1) {
 +				retp->lc=tmpc;
 +				retp->hc=tmpc1;
 +			} else {
 +				retp->lc=tmpc1;
 +				retp->hc=tmpc;
 +			}
 +			*ptr= p;
 +			return RANGE | abz;
 +		}
 +		retp->lr = retp->hr = tmpr;
 +		retp->lc = retp->hc = tmpc;
 +		*ptr=p;
 +		return R_CELL | abz;
 +	} else {
 +		char *p;
 +		unsigned char retr;
 +		unsigned char retc;
 +		int ended;
 +		long num;
 +		CELLREF tmp;
 +
 +#define CK_ABS_R(x)	if((x)<MIN_ROW || (x)>MAX_ROW)	\
 +				return 0;		\
 +			else
 +
 +#define CK_REL_R(x)	if(   ((x)>0 && MAX_ROW-(x)<cur_row)	\
 +			   || ((x)<0 && MIN_ROW-(x)>cur_row))	\
 +				return 0;			\
 +			else
 +
 +#define CK_ABS_C(x)	if((x)<MIN_COL || (x)>MAX_COL)	\
 +				return 0;		\
 +			else
 +
 +#define CK_REL_C(x)	if(   ((x)>0 && MAX_COL-(x)<cur_col)	\
 +			   || ((x)<0 && MIN_COL-(x)>cur_col))	\
 +				return 0;			\
 +			else
 +
 +#define MAYBEREL(p) (*(p)=='[' && (isdigit((p)[1]) || (((p)[1]=='+' || (p)[1]=='-') && isdigit((p)[2]))))
 +
 +		p= *ptr;
 +		retr=0;
 +		retc=0;
 +		ended=0;
 +		while(ended==0) {
 +			switch(*p) {
 +			case 'r':
 +			case 'R':
 +				if(retr) {
 +					ended++;
 +					break;
 +				}
 +				p++;
 +				retr=R_CELL;
 +				if(isdigit(*p)) {
 +					num=astol(&p);
 +					CK_ABS_R(num);
 +					retp->lr= retp->hr=num;
 +				} else if(MAYBEREL(p)) {
 +					p++;
 +					num=astol(&p);
 +					CK_REL_R(num);
 +					retp->lr= retp->hr=num+cur_row;
 +					retr|=ROWREL;
 +					if(*p==':') {
 +						retr=RANGE|LRREL|HRREL;
 +						p++;
 +						num=astol(&p);
 +						CK_REL_R(num);
 +						retp->hr=num+cur_row;
 +					}
 +					if(*p++!=']')
 +						return 0;
 +				} else if(retc || *p=='c' || *p=='C') {
 +					retr|=ROWREL;
 +					retp->lr= retp->hr=cur_row;
 +				} else
 +					return 0;
 +				if(*p==':' && retr!=(RANGE|LRREL|HRREL)) {
 +					retr= (retr&ROWREL) ? RANGE|LRREL : RANGE;
 +					p++;
 +					if(isdigit(*p)) {
 +						num=astol(&p);
 +						CK_ABS_R(num);
 +			 			retp->hr=num;
 +					} else if(MAYBEREL(p)) {
 +						p++;
 +						num=astol(&p);
 +						CK_REL_R(num);
 +						retp->hr=num+cur_row;
 +						retr|=HRREL;
 +						if(*p++!=']')
 +							return 0;
 +					} else
 +						return 0;
 +				}
 +
 +				if(retc)
 +					ended++;
 +				break;
 +
 +			case 'c':
 +			case 'C':
 +				if(retc) {
 +					ended++;
 +					break;
 +				}
 +				p++;
 +				retc=R_CELL;
 +				if(isdigit(*p)) {
 +					num=astol(&p);
 +					CK_ABS_C(num);
 +					retp->lc= retp->hc=num;
 +				} else if(MAYBEREL(p)) {
 +					p++;
 +					num=astol(&p);
 +					CK_REL_C(num);
 +					retp->lc= retp->hc=num+cur_col;
 +					retc|=COLREL;
 +					if(*p==':') {
 +						retc=RANGE|LCREL|HCREL;
 +						p++;
 +						num=astol(&p);
 +						CK_REL_C(num);
 +						retp->hc=num+cur_col;
 +					}
 +					if(*p++!=']')
 +						return 0;
 +				} else if(retr || *p=='r' || *p=='R') {
 +					retc|=COLREL;
 +					retp->lc= retp->hc=cur_col;
 +				} else
 +					return 0;
 +				if(*p==':' && retc!=(RANGE|LCREL|HCREL)) {
 +					retc= (retc&COLREL) ? RANGE|LCREL : RANGE;
 +					p++;
 +					if(isdigit(*p)) {
 +						num=astol(&p);
 +						CK_ABS_C(num);
 +			 			retp->hc=num;
 +					} else if(MAYBEREL(p)) {
 +						p++;
 +						num=astol(&p);
 +						CK_REL_C(num);
 +						retp->hc=num+cur_col;
 +						retc|=HCREL;
 +						if(*p++!=']')
 +							return 0;
 +					} else
 +						return 0;
 +				}
 +
 +				if(retr)
 +					ended++;
 +				break;
 +			default:
 +				if(retr) {
 +					*ptr=p;
 +					retp->lc=MIN_COL;
 +					retp->hc=MAX_COL;
 +					if((retr|ROWREL)==(R_CELL|ROWREL))
 +						return (retr&ROWREL) ? (RANGE|LRREL|HRREL) : RANGE;
 +					else
 +						return retr;
 +				} else if(retc) {
 +					*ptr=p;
 +					retp->lr=MIN_ROW;
 +					retp->hr=MAX_COL;
 +					if((retc|COLREL)==(R_CELL|COLREL))
 +						return (retc&COLREL) ? (RANGE|LCREL|HCREL) : RANGE;
 +					else
 +						return retc;
 +				}
 +				return 0;
 +			}
 +		}
 +		if(!retr || !retc)
 +			return 0;
 +		*ptr=p;
 +		if(retp->lr>retp->hr)
 +			tmp=retp->lr,retp->lr=retp->hr,retp->hr=tmp;
 +		if(retp->lc>retp->hc)
 +			tmp=retp->lc,retp->lc=retp->hc,retp->hc=tmp;
 +
 +		if((retr|ROWREL)==(R_CELL|ROWREL)) {
 +			if((retc|COLREL)==(R_CELL|COLREL))
 +				return retr|retc;
 +			return (retr&ROWREL) ? (retc|LRREL|HRREL) : retc;
 +		}
 +		if((retc|COLREL)==(R_CELL|COLREL))
 +			return (retc&COLREL) ? (retr|LCREL|HCREL) : retr;
 +		return retr|retc;
 +	}
 +}
 +
 +int
 +str_to_col FUN1(char **,str)
 +{
 +	int ret;
 +	char c,cc,ccc;
 +#if MAX_COL>702
 +	char cccc;
 +#endif
 +
 +	ret=0;
 +	c=str[0][0];
 +	if(!isalpha((cc=str[0][1]))) {
 +		(*str)++;
 +		return MIN_COL + (isupper(c) ? c-'A' : c-'a');
 +	}
 +	if(!isalpha((ccc=str[0][2]))) {
 +		(*str)+=2;
 +		return MIN_COL+26 + (isupper(c) ? c-'A' : c-'a')*26 + (isupper(cc) ? cc-'A' : cc-'a');
 +	}
 +#if MAX_COL>702
 +	if(!isalpha((cccc=str[0][3]))) {
 +		(*str)+=3;
 +		return MIN_COL+702 + (isupper(c) ? c-'A' : c-'a')*26*26 + (isupper(cc) ? cc-'A' : cc-'a')*26 + (isupper(ccc) ? ccc-'A' : ccc-'a');
 +	}
 +	if(!isalpha(str[0][4])) {
 +		(*str)+=4;
 +		return MIN_COL+18278 + (isupper(c) ? c-'A' : c-'a')*26*26*26 + (isupper(cc) ? cc-'A' : cc-'a')*26*26 + (isupper(ccc) ? ccc-'A' : ccc-'a')*26 + (isupper(cccc) ? cccc-'A' : cccc-'a');
 +	}
 +#endif
 +	return 0;
 +}
diff --cc test/manual/etags/y-src/parse.y
index 824c98d6245,00000000000..b40847dd559
mode 100644,000000..100644
--- a/test/manual/etags/y-src/parse.y
+++ b/test/manual/etags/y-src/parse.y
@@@ -1,875 -1,0 +1,876 @@@
 +%{
- /*	Copyright (C) 1990, 1992-1993, 2016 Free Software Foundation, Inc.
++/*	Copyright (C) 1990, 1992-1993, 2016-2017 Free Software Foundation,
++ *	Inc.
 +
 +This file is part of Oleo, the GNU Spreadsheet.
 +
 +Oleo is free software; you can redistribute it and/or modify
 +it under the terms of the GNU General Public License as published by
 +the Free Software Foundation; either version 2, or (at your option)
 +any later version.
 +
 +Oleo is distributed in the hope that it will be useful,
 +but WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +GNU General Public License for more details.
 +
 +You should have received a copy of the GNU General Public License
 +along with Oleo; see the file COPYING.  If not, write to
 +the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
 +%}
 +
 +
 +%right '?' ':'
 +/* %left '|' */
 +%left '&'
 +%nonassoc '=' NE
 +%nonassoc '<' LE '>' GE
 +%left '+' '-'
 +%left '*' '/' '%'
 +%right '^'
 +%left NEG '!'
 +
 +%token	L_CELL L_RANGE
 +%token	L_VAR
 +
 +%token	L_CONST
 +%token	L_FN0	L_FN1	L_FN2	L_FN3	L_FN4	L_FNN
 +%token	L_FN1R	L_FN2R	L_FN3R	L_FN4R	L_FNNR
 +
 +%token	L_LE	L_NE	L_GE
 +
 +%{
 +#include "funcdef.h"
 +
 +#include <ctype.h>
 +
 +#define obstack_chunk_alloc ck_malloc
 +#define obstack_chunk_free free
 +#include "obstack.h"
 +#include "sysdef.h"
 +
 +#include "global.h"
 +#include "errors.h"
 +#include "node.h"
 +#include "eval.h"
 +#include "ref.h"
 +
 +int yylex ();
 +#ifdef __STDC__
 +void yyerror (char *);
 +#else
 +void yyerror ();
 +#endif
 +VOIDSTAR parse_hash;
 +extern VOIDSTAR hash_find();
 +
 +/* This table contains a list of the infix single-char functions */
 +unsigned char fnin[] = {
 +	SUM, DIFF, DIV, PROD, MOD, /* AND, OR, */ POW, EQUAL, IF, CONCAT, 0
 +};
 +
 +#define YYSTYPE _y_y_s_t_y_p_e
 +typedef struct node *YYSTYPE;
 +YYSTYPE parse_return;
 +#ifdef __STDC__
 +YYSTYPE make_list (YYSTYPE, YYSTYPE);
 +#else
 +YYSTYPE make_list ();
 +#endif
 +
 +char *instr;
 +int parse_error = 0;
 +extern struct obstack tmp_mem;
 +
 +%}
 +%%
 +line:	exp
 +		{ parse_return=$1; }
 +	| error {
 +		if(!parse_error)
 +			parse_error=PARSE_ERR;
 +		parse_return=0; }
 +	;
 +
 +exp:	  L_CONST
 +	| cell
 +	| L_FN0 '(' ')' {
 +		$$=$1; }
 +	| L_FN1 '(' exp ')' {
 +		($1)->n_x.v_subs[0]=$3;
 +		($1)->n_x.v_subs[1]=(struct node *)0;
 +		$$=$1; }
 +	| L_FN2 '(' exp ',' exp ')' {
 +		($1)->n_x.v_subs[0]=$3;
 +		($1)->n_x.v_subs[1]=$5;
 +		$$=$1; }
 +	| L_FN3 '(' exp ',' exp ',' exp ')' {
 +		($1)->n_x.v_subs[0]=make_list($3,$5);
 + 		($1)->n_x.v_subs[1]=$7;
 + 		$$=$1;}
 +	| L_FN4 '(' exp ',' exp ',' exp ',' exp ')' {
 +		($1)->n_x.v_subs[0]=make_list($3,$5);
 + 		($1)->n_x.v_subs[1]=make_list($7,$9);
 + 		$$=$1;}
 +	| L_FNN '(' exp_list ')' {
 +		($1)->n_x.v_subs[0]=(struct node *)0;
 +		($1)->n_x.v_subs[1]=$3;
 +		$$=$1; }
 +	| L_FN1R '(' L_RANGE ')' {
 +		$1->n_x.v_subs[0]=$3;
 +		$$=$1; }
 +	| L_FN1R '(' L_VAR ')' {
 +		$1->n_x.v_subs[0]=$3;
 +		$$=$1; }
 +
 +	| L_FN2R '(' L_RANGE ',' exp ')' {
 +		$1->n_x.v_subs[0]=$3;
 +		$1->n_x.v_subs[1]=$5;
 +		$$=$1; }
 +	| L_FN2R '(' L_VAR ',' exp ')' {
 +		$1->n_x.v_subs[0]=$3;
 +		$1->n_x.v_subs[1]=$5;
 +		$$=$1; }
 +
 +	/* JF:  These should be FN2R, but I'm hacking this for SYLNK */
 +	| L_FN2R '(' L_RANGE ',' exp ',' exp ')' {
 +		if($1->comp_value!=F_INDEX)
 +			parse_error=PARSE_ERR;
 +		$1->comp_value=F_INDEX2;
 +		$1->n_x.v_subs[0]=make_list($3,$5);
 +		$1->n_x.v_subs[1]=$7;
 +		$$=$1; }
 +	| L_FN2R '(' L_VAR ',' exp ',' exp ')' {
 +		if($1->comp_value!=F_INDEX)
 +			parse_error=PARSE_ERR;
 +		$1->comp_value=F_INDEX2;
 +		$1->n_x.v_subs[0]=make_list($3,$5);
 +		$1->n_x.v_subs[1]=$7;
 +		$$=$1; }
 +
 +	| L_FN3R '(' L_RANGE ',' exp ',' exp ')' {
 +		($1)->n_x.v_subs[0]=make_list($3,$5);
 + 		($1)->n_x.v_subs[1]=$7;
 + 		$$=$1;}
 +	| L_FN3R '(' L_VAR ',' exp ',' exp ')' {
 +		($1)->n_x.v_subs[0]=make_list($3,$5);
 + 		($1)->n_x.v_subs[1]=$7;
 + 		$$=$1;}
 +
 +	| L_FNNR '(' range_exp_list ')' {
 +		($1)->n_x.v_subs[0]=(struct node *)0;
 +		($1)->n_x.v_subs[1]=$3;
 +		$$=$1; }
 +	| exp '?' exp ':' exp {
 +		$2->comp_value=IF;
 +		$2->n_x.v_subs[0]=$4;
 +		$2->n_x.v_subs[1]=$5;
 +		$4->n_x.v_subs[0]=$1;
 +		$4->n_x.v_subs[1]=$3;
 +		$$=$2; }
 +	/* | exp '|' exp {
 +		$2->n_x.v_subs[0]=$1;
 +		$2->n_x.v_subs[1]=$3;
 +		$$ = $2; } */
 +	| exp '&' exp {
 +		$2->n_x.v_subs[0]=$1;
 +		$2->n_x.v_subs[1]=$3;
 +		$$ = $2; }
 +	| exp '<' exp {
 +		$2->n_x.v_subs[0]=$1;
 +		$2->n_x.v_subs[1]=$3;
 +		$$ = $2; }
 +	| exp LE exp {
 +		$2->n_x.v_subs[0]=$1;
 +		$2->n_x.v_subs[1]=$3;
 +		$$ = $2; }
 +	| exp '=' exp {
 +		$2->n_x.v_subs[0]=$1;
 +		$2->n_x.v_subs[1]=$3;
 +		$$ = $2; }
 +	| exp NE exp {
 +		$2->n_x.v_subs[0]=$1;
 +		$2->n_x.v_subs[1]=$3;
 +		$$ = $2; }
 +	| exp '>' exp {
 +		$2->n_x.v_subs[0]=$1;
 +		$2->n_x.v_subs[1]=$3;
 +		$$ = $2; }
 +	| exp GE exp {
 +		$2->n_x.v_subs[0]=$1;
 +		$2->n_x.v_subs[1]=$3;
 +		$$ = $2; }
 +	| exp '+' exp {
 +		$2->n_x.v_subs[0]=$1;
 +		$2->n_x.v_subs[1]=$3;
 +		$$ = $2; }
 +	| exp '-' exp {
 +		$2->n_x.v_subs[0]=$1;
 +		$2->n_x.v_subs[1]=$3;
 +		$$ = $2; }
 +	| exp '*' exp {
 +		$2->n_x.v_subs[0]=$1;
 +		$2->n_x.v_subs[1]=$3;
 +		$$ = $2; }
 +	| exp '/' exp {
 +		$2->n_x.v_subs[0]=$1;
 +		$2->n_x.v_subs[1]=$3;
 +		$$ = $2; }
 +	| exp '%' exp {
 +		$2->n_x.v_subs[0]=$1;
 +		$2->n_x.v_subs[1]=$3;
 +		$$ = $2; }
 +	| exp '^' exp {
 +		$2->n_x.v_subs[0]=$1;
 +		$2->n_x.v_subs[1]=$3;
 +		$$ = $2; }
 +	| '-' exp %prec NEG {
 +		if($2->comp_value==CONST_FLT) {
 +			$2->n_x.v_float= -($2->n_x.v_float);
 +			/* free($1); */
 +			$$=$2;
 +		} else if($2->comp_value==CONST_INT) {
 +			$2->n_x.v_int= -($2->n_x.v_int);
 +			/* free($1); */
 +			$$=$2;
 +		} else {
 +			$1->comp_value = NEGATE;
 +			$1->n_x.v_subs[0]=$2;
 +			$1->n_x.v_subs[1]=(struct node *)0;
 +			$$ = $1;
 +		} }
 +	| '!' exp {
 +		$1->n_x.v_subs[0]=$2;
 +		$1->n_x.v_subs[1]=(struct node *)0;
 +		$$ = $1; }
 +	| '(' exp ')'
 +		{ $$ = $2; }
 +	| '(' exp error {
 +		if(!parse_error)
 +			parse_error=NO_CLOSE;
 +		}
 +	/* | exp ')' error {
 +		if(!parse_error)
 +			parse_error=NO_OPEN;
 +		} */
 +	| '(' error {
 +		if(!parse_error)
 +			parse_error=NO_CLOSE;
 +		}
 +	;
 +
 +
 +exp_list: exp
 + 		{ $$ = make_list($1, 0); }
 +	| exp_list ',' exp
 +		{ $$ = make_list($3, $1); }
 +	;
 +
 +range_exp: L_RANGE
 +	| exp
 +	;
 +
 +range_exp_list: range_exp
 +		{ $$=make_list($1, 0); }
 +	|   range_exp_list ',' range_exp
 +		{ $$=make_list($3,$1); }
 +	;
 +
 +cell:	L_CELL
 +		{ $$=$1; }
 +	| L_VAR
 +	;
 +%%
 +
 +void
 +yyerror FUN1(char *, s)
 +{
 +	if(!parse_error)
 +		parse_error=PARSE_ERR;
 +}
 +
 +YYSTYPE
 +make_list FUN2(YYSTYPE, car, YYSTYPE, cdr)
 +{
 +	YYSTYPE ret;
 +
 +	ret=(YYSTYPE)obstack_alloc(&tmp_mem,sizeof(*ret));
 +	ret->comp_value = 0;
 +	ret->n_x.v_subs[0]=car;
 +	ret->n_x.v_subs[1]=cdr;
 +	return ret;
 +}
 +
 +#define ERROR -1
 +
 +extern struct node *yylval;
 +
 +#ifdef __STDC__
 +unsigned char parse_cell_or_range (char **,struct rng *);
 +#else
 +unsigned char parse_cell_or_range ();
 +#endif
 +
 +int
 +yylex FUN0()
 +{
 +	int ch;
 +	struct node *new;
 +	int isflt;
 +	char *begin;
 +	char *tmp_str;
 +	unsigned char byte_value;
 +	int n;
 +
 +	/* unsigned char *ptr; */
 +	int nn;
 +	struct function *fp;
 +	int tmp_ch;
 +
 +#ifdef TEST
 +	if(!instr)
 +		return ERROR;
 +#endif
 +	while(isspace(*instr))
 +		instr++;
 +	ch = *instr++;
 +	if(ch=='(' || ch==',' || ch==')')
 +		return ch;
 +
 +	new=(struct node *)obstack_alloc(&tmp_mem,sizeof(struct node));
 +	new->add_byte=0;
 +	new->sub_value=0;
 +	switch(ch) {
 +	case 0:
 +		return 0;
 +
 +	case '0': case '1': case '2': case '3': case '4': case '5': case '6':
 +	case '7': case '8': case '9': case '.':
 +		isflt = (ch=='.');
 +
 +		begin=instr-1;
 +		tmp_str=instr;
 +
 +		while(isdigit(*tmp_str) || (!isflt && *tmp_str=='.' && ++isflt))
 +			tmp_str++;
 +		if(*tmp_str=='e' || *tmp_str=='E') {
 +			isflt=1;
 +			tmp_str++;
 +			if(*tmp_str=='-' || *tmp_str=='+')
 +				tmp_str++;
 +			while(isdigit(*tmp_str))
 +				tmp_str++;
 +		}
 +		if(isflt) {
 +			new->n_x.v_float=astof((char **)(&begin));
 +			byte_value=CONST_FLT;
 +		} else {
 +			new->n_x.v_int=astol((char **)(&begin));
 +			if(begin!=tmp_str) {
 +				begin=instr-1;
 +				new->n_x.v_float=astof((char **)(&begin));
 +				byte_value=CONST_FLT;
 +			} else
 +				byte_value=CONST_INT;
 +		}
 +		ch=L_CONST;
 +		instr=begin;
 +		break;
 +
 +	case '"':
 +		begin=instr;
 +		while(*instr && *instr!='"') {
 +			if(*instr=='\\' && instr[1])
 +				instr++;
 +			instr++;
 +		}
 +		if(!*instr) {
 +			parse_error=NO_QUOTE;
 +			return ERROR;
 +		}
 +		tmp_str=new->n_x.v_string=(char *)ck_malloc(1+instr-begin);
 +		while(begin!=instr) {
 +			unsigned char n;
 +
 +			if(*begin=='\\') {
 +				begin++;
 +				if(begin[0]>='0' && begin[0]<='7') {
 +					if(begin[1]>='0' && begin[1]<='7') {
 +						if(begin[2]>='0' && begin[2]<='7') {
 +							n=(begin[2]-'0') + (010 * (begin[1]-'0')) + ( 0100 * (begin[0]-'0'));
 +							begin+=3;
 +						} else {
 +							n=(begin[1]-'0') + (010 * (begin[0]-'0'));
 +							begin+=2;
 +						}
 +					} else {
 +						n=begin[0]-'0';
 +						begin++;
 +					}
 +				} else
 +					n= *begin++;
 +				*tmp_str++= n;
 +			} else
 +				*tmp_str++= *begin++;
 +		}
 +		*tmp_str='\0';
 +		instr++;
 +		byte_value=CONST_STR;
 +		ch=L_CONST;
 +		break;
 +
 +	case '+':	case '-':
 +
 +	case '*':	case '/':	case '%':	case '&':
 +	/* case '|': */	case '^':	case '=':
 +
 +	case '?':
 +	{
 +		unsigned char *ptr;
 +
 +		for(ptr= fnin;*ptr;ptr++)
 +			if(the_funs[*ptr].fn_str[0]==ch)
 +				break;
 +#ifdef TEST
 +		if(!*ptr)
 +			panic("Can't find fnin[] entry for '%c'",ch);
 +#endif
 +		byte_value= *ptr;
 +	}
 +		break;
 +
 +	case ':':
 +		byte_value=IF;
 +		break;
 +
 +	case '!':
 +	case '<':
 +	case '>':
 +		if(*instr!='=') {
 +			byte_value = (ch=='<') ? LESS : (ch=='>') ? GREATER : NOT;
 +			break;
 +		}
 +		instr++;
 +		byte_value = (ch=='<') ? LESSEQ : (ch=='>') ? GREATEQ : NOTEQUAL;
 +		ch = (ch=='<') ? LE : (ch=='>') ? GE : NE;
 +		break;
 +
 +	case '\'':
 +	case ';':
 +	case '[':
 +	case '\\':
 +	case ']':
 +	case '`':
 +	case '{':
 +	case '}':
 +	case '~':
 +	bad_chr:
 +		parse_error=BAD_CHAR;
 +		return ERROR;
 +
 +	case '#':
 +		begin=instr-1;
 +		while(*instr && (isalnum(*instr) || *instr=='_'))
 +			instr++;
 +		ch= *instr;
 +		*instr=0;
 +		if(!stricmp(begin,tname))
 +			byte_value=F_TRUE;
 +		else if(!stricmp(begin,fname))
 +			byte_value=F_FALSE;
 +		else if(!stricmp(begin,iname) && (begin[4]==0 || !stricmp(begin+4,"inity")))
 +			byte_value=CONST_INF;
 +		else if(!stricmp(begin,mname) ||
 +			!stricmp(begin,"#ninf"))
 +			byte_value=CONST_NINF;
 +		else if(!stricmp(begin,nname) ||
 +			!stricmp(begin,"#nan"))
 +			byte_value=CONST_NAN;
 +		else {
 +			for(n=1;n<=ERR_MAX;n++)
 +				if(!stricmp(begin,ename[n]))
 +					break;
 +			if(n>ERR_MAX)
 +				n=BAD_CHAR;
 +			new->n_x.v_int=n;
 +			byte_value=CONST_ERR;
 +		}
 +		*instr=ch;
 +		ch=L_CONST;
 +		break;
 +
 +	default:
 +		if(!a0 && (ch=='@' || ch=='$'))
 +		   goto bad_chr;
 +
 +		if(a0 && ch=='@') {
 +			begin=instr;
 +			while(*instr && (isalpha(*instr) || isdigit(*instr) || *instr=='_'))
 +				instr++;
 +			n=instr-begin;
 +		} else {
 +			begin=instr-1;
 +			byte_value=parse_cell_or_range(&begin,&(new->n_x.v_rng));
 +			if(byte_value) {
 +				if((byte_value& ~0x3)==R_CELL)
 +					ch=L_CELL;
 +				else
 +					ch=L_RANGE;
 +				instr=begin;
 +				break;
 +			}
 +
 +			while(*instr && (isalpha(*instr) || isdigit(*instr) || *instr=='_'))
 +				instr++;
 +
 +			n=instr-begin;
 +			while(isspace(*instr))
 +				instr++;
 +
 +			if(*instr!='(') {
 +				ch=L_VAR;
 +				byte_value=VAR;
 +				new->n_x.v_var=find_or_make_var(begin,n);
 +				break;
 +			}
 +		}
 +		tmp_ch=begin[n];
 +		begin[n]='\0';
 +		fp=hash_find(parse_hash,begin);
 +		begin[n]=tmp_ch;
 +		byte_value= ERROR;
 +		if(!fp) {
 +			parse_error=BAD_FUNC;
 +			return ERROR;
 +		}
 +
 +		if(fp>=the_funs && fp<=&the_funs[USR1])
 +			byte_value=fp-the_funs;
 +		else {
 +			for(nn=0;nn<n_usr_funs;nn++) {
 +				if(fp>=&usr_funs[nn][0] && fp<=&usr_funs[nn][usr_n_funs[nn]]) {
 +					byte_value=USR1+nn;
 +					new->sub_value=fp-&usr_funs[nn][0];
 +					break;
 +				}
 +			}
 +#ifdef TEST
 +			if(nn==n_usr_funs) {
 +				io_error_msg("Couln't turn fp into a ##");
 +				parse_error=BAD_FUNC;
 +				return ERROR;
 +			}
 +#endif
 +		}
 +
 +		if(fp->fn_argn&X_J)
 +			ch= byte_value==F_IF ? L_FN3 : L_FN2;
 +		else if(fp->fn_argt[0]=='R' || fp->fn_argt[0]=='E')
 +			ch=L_FN1R-1+fp->fn_argn-X_A0;
 +		else
 +			ch=L_FN0 + fp->fn_argn-X_A0;
 +
 +		break;
 +	}
 +	/* new->node_type=ch; */
 +	new->comp_value=byte_value;
 +	yylval=new;
 +	return ch;
 +}
 +
 +/* Return value is
 +	0 if it doesn't look like a cell or a range,
 +	R_CELL if it is a cell (ptr now points past the characters, lr and lc hold the row and col of the cell)
 +	RANGE if it is a range (ptr points past the chars)
 + */
 +unsigned char
 +parse_cell_or_range FUN2(char **,ptr, struct rng *,retp)
 +{
 +	if(a0) {
 +		unsigned tmpc,tmpr;
 +		char *p;
 +		int abz = ROWREL|COLREL;
 +
 +		p= *ptr;
 +		tmpc=0;
 +		if(*p=='$') {
 +			abz-=COLREL;
 +			p++;
 +		}
 +		if(!isalpha(*p))
 +			return 0;
 +		tmpc=str_to_col(&p);
 +		if(tmpc<MIN_COL || tmpc>MAX_COL)
 +			return 0;
 +		if(*p=='$') {
 +			abz-=ROWREL;
 +			p++;
 +		}
 +		if(!isdigit(*p))
 +			return 0;
 +		for(tmpr=0;isdigit(*p);p++)
 +			tmpr=tmpr*10 + *p - '0';
 +
 +		if(tmpr<MIN_ROW || tmpr>MAX_ROW)
 +			return 0;
 +
 +		if(*p==':' || *p=='.') {
 +			unsigned tmpc1,tmpr1;
 +
 +			abz = ((abz&COLREL) ? LCREL : 0)|((abz&ROWREL) ? LRREL : 0)|HRREL|HCREL;
 +			p++;
 +			if(*p=='$') {
 +				abz-=HCREL;
 +				p++;
 +			}
 +			if(!isalpha(*p))
 +				return 0;
 +			tmpc1=str_to_col(&p);
 +			if(tmpc1<MIN_COL || tmpc1>MAX_COL)
 +				return 0;
 +			if(*p=='$') {
 +				abz-=HRREL;
 +				p++;
 +			}
 +			if(!isdigit(*p))
 +				return 0;
 +			for(tmpr1=0;isdigit(*p);p++)
 +				tmpr1=tmpr1*10 + *p - '0';
 +			if(tmpr1<MIN_ROW || tmpr1>MAX_ROW)
 +				return 0;
 +
 +			if(tmpr<tmpr1) {
 +				retp->lr=tmpr;
 +				retp->hr=tmpr1;
 +			} else {
 +				retp->lr=tmpr1;
 +				retp->hr=tmpr;
 +			}
 +			if(tmpc<tmpc1) {
 +				retp->lc=tmpc;
 +				retp->hc=tmpc1;
 +			} else {
 +				retp->lc=tmpc1;
 +				retp->hc=tmpc;
 +			}
 +			*ptr= p;
 +			return RANGE | abz;
 +		}
 +		retp->lr = retp->hr = tmpr;
 +		retp->lc = retp->hc = tmpc;
 +		*ptr=p;
 +		return R_CELL | abz;
 +	} else {
 +		char *p;
 +		unsigned char retr;
 +		unsigned char retc;
 +		int ended;
 +		long num;
 +		CELLREF tmp;
 +
 +#define CK_ABS_R(x)	if((x)<MIN_ROW || (x)>MAX_ROW)	\
 +				return 0;		\
 +			else
 +
 +#define CK_REL_R(x)	if(   ((x)>0 && MAX_ROW-(x)<cur_row)	\
 +			   || ((x)<0 && MIN_ROW-(x)>cur_row))	\
 +				return 0;			\
 +			else
 +
 +#define CK_ABS_C(x)	if((x)<MIN_COL || (x)>MAX_COL)	\
 +				return 0;		\
 +			else
 +
 +#define CK_REL_C(x)	if(   ((x)>0 && MAX_COL-(x)<cur_col)	\
 +			   || ((x)<0 && MIN_COL-(x)>cur_col))	\
 +				return 0;			\
 +			else
 +
 +#define MAYBEREL(p) (*(p)=='[' && (isdigit((p)[1]) || (((p)[1]=='+' || (p)[1]=='-') && isdigit((p)[2]))))
 +
 +		p= *ptr;
 +		retr=0;
 +		retc=0;
 +		ended=0;
 +		while(ended==0) {
 +			switch(*p) {
 +			case 'r':
 +			case 'R':
 +				if(retr) {
 +					ended++;
 +					break;
 +				}
 +				p++;
 +				retr=R_CELL;
 +				if(isdigit(*p)) {
 +					num=astol(&p);
 +					CK_ABS_R(num);
 +					retp->lr= retp->hr=num;
 +				} else if(MAYBEREL(p)) {
 +					p++;
 +					num=astol(&p);
 +					CK_REL_R(num);
 +					retp->lr= retp->hr=num+cur_row;
 +					retr|=ROWREL;
 +					if(*p==':') {
 +						retr=RANGE|LRREL|HRREL;
 +						p++;
 +						num=astol(&p);
 +						CK_REL_R(num);
 +						retp->hr=num+cur_row;
 +					}
 +					if(*p++!=']')
 +						return 0;
 +				} else if(retc || *p=='c' || *p=='C') {
 +					retr|=ROWREL;
 +					retp->lr= retp->hr=cur_row;
 +				} else
 +					return 0;
 +				if(*p==':' && retr!=(RANGE|LRREL|HRREL)) {
 +					retr= (retr&ROWREL) ? RANGE|LRREL : RANGE;
 +					p++;
 +					if(isdigit(*p)) {
 +						num=astol(&p);
 +						CK_ABS_R(num);
 +			 			retp->hr=num;
 +					} else if(MAYBEREL(p)) {
 +						p++;
 +						num=astol(&p);
 +						CK_REL_R(num);
 +						retp->hr=num+cur_row;
 +						retr|=HRREL;
 +						if(*p++!=']')
 +							return 0;
 +					} else
 +						return 0;
 +				}
 +
 +				if(retc)
 +					ended++;
 +				break;
 +
 +			case 'c':
 +			case 'C':
 +				if(retc) {
 +					ended++;
 +					break;
 +				}
 +				p++;
 +				retc=R_CELL;
 +				if(isdigit(*p)) {
 +					num=astol(&p);
 +					CK_ABS_C(num);
 +					retp->lc= retp->hc=num;
 +				} else if(MAYBEREL(p)) {
 +					p++;
 +					num=astol(&p);
 +					CK_REL_C(num);
 +					retp->lc= retp->hc=num+cur_col;
 +					retc|=COLREL;
 +					if(*p==':') {
 +						retc=RANGE|LCREL|HCREL;
 +						p++;
 +						num=astol(&p);
 +						CK_REL_C(num);
 +						retp->hc=num+cur_col;
 +					}
 +					if(*p++!=']')
 +						return 0;
 +				} else if(retr || *p=='r' || *p=='R') {
 +					retc|=COLREL;
 +					retp->lc= retp->hc=cur_col;
 +				} else
 +					return 0;
 +				if(*p==':' && retc!=(RANGE|LCREL|HCREL)) {
 +					retc= (retc&COLREL) ? RANGE|LCREL : RANGE;
 +					p++;
 +					if(isdigit(*p)) {
 +						num=astol(&p);
 +						CK_ABS_C(num);
 +			 			retp->hc=num;
 +					} else if(MAYBEREL(p)) {
 +						p++;
 +						num=astol(&p);
 +						CK_REL_C(num);
 +						retp->hc=num+cur_col;
 +						retc|=HCREL;
 +						if(*p++!=']')
 +							return 0;
 +					} else
 +						return 0;
 +				}
 +
 +				if(retr)
 +					ended++;
 +				break;
 +			default:
 +				if(retr) {
 +					*ptr=p;
 +					retp->lc=MIN_COL;
 +					retp->hc=MAX_COL;
 +					if((retr|ROWREL)==(R_CELL|ROWREL))
 +						return (retr&ROWREL) ? (RANGE|LRREL|HRREL) : RANGE;
 +					else
 +						return retr;
 +				} else if(retc) {
 +					*ptr=p;
 +					retp->lr=MIN_ROW;
 +					retp->hr=MAX_COL;
 +					if((retc|COLREL)==(R_CELL|COLREL))
 +						return (retc&COLREL) ? (RANGE|LCREL|HCREL) : RANGE;
 +					else
 +						return retc;
 +				}
 +				return 0;
 +			}
 +		}
 +		if(!retr || !retc)
 +			return 0;
 +		*ptr=p;
 +		if(retp->lr>retp->hr)
 +			tmp=retp->lr,retp->lr=retp->hr,retp->hr=tmp;
 +		if(retp->lc>retp->hc)
 +			tmp=retp->lc,retp->lc=retp->hc,retp->hc=tmp;
 +
 +		if((retr|ROWREL)==(R_CELL|ROWREL)) {
 +			if((retc|COLREL)==(R_CELL|COLREL))
 +				return retr|retc;
 +			return (retr&ROWREL) ? (retc|LRREL|HRREL) : retc;
 +		}
 +		if((retc|COLREL)==(R_CELL|COLREL))
 +			return (retc&COLREL) ? (retr|LCREL|HCREL) : retr;
 +		return retr|retc;
 +	}
 +}
 +
 +int
 +str_to_col FUN1(char **,str)
 +{
 +	int ret;
 +	char c,cc,ccc;
 +#if MAX_COL>702
 +	char cccc;
 +#endif
 +
 +	ret=0;
 +	c=str[0][0];
 +	if(!isalpha((cc=str[0][1]))) {
 +		(*str)++;
 +		return MIN_COL + (isupper(c) ? c-'A' : c-'a');
 +	}
 +	if(!isalpha((ccc=str[0][2]))) {
 +		(*str)+=2;
 +		return MIN_COL+26 + (isupper(c) ? c-'A' : c-'a')*26 + (isupper(cc) ? cc-'A' : cc-'a');
 +	}
 +#if MAX_COL>702
 +	if(!isalpha((cccc=str[0][3]))) {
 +		(*str)+=3;
 +		return MIN_COL+702 + (isupper(c) ? c-'A' : c-'a')*26*26 + (isupper(cc) ? cc-'A' : cc-'a')*26 + (isupper(ccc) ? ccc-'A' : ccc-'a');
 +	}
 +	if(!isalpha(str[0][4])) {
 +		(*str)+=4;
 +		return MIN_COL+18278 + (isupper(c) ? c-'A' : c-'a')*26*26*26 + (isupper(cc) ? cc-'A' : cc-'a')*26*26 + (isupper(ccc) ? ccc-'A' : ccc-'a')*26 + (isupper(cccc) ? cccc-'A' : cccc-'a');
 +	}
 +#endif
 +	return 0;
 +}
diff --cc test/manual/indent/pascal.pas
index 2d09eb775a4,00000000000..fd225fd35d1
mode 100644,000000..100644
--- a/test/manual/indent/pascal.pas
+++ b/test/manual/indent/pascal.pas
@@@ -1,1092 -1,0 +1,1092 @@@
 +{ GPC demo program for the CRT unit.
 +
- Copyright (C) 1999-2006, 2013-2016 Free Software Foundation, Inc.
++Copyright (C) 1999-2006, 2013-2017 Free Software Foundation, Inc.
 +
 +Author: Frank Heckenbach <frank@pascal.gnu.de>
 +
 +This program is free software; you can redistribute it and/or
 +modify it under the terms of the GNU General Public License as
 +published by the Free Software Foundation, version 3.
 +
 +This program is distributed in the hope that it will be useful,
 +but WITHOUT ANY WARRANTY; without even the implied warranty of
 +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
 +General Public License for more details.
 +
 +You should have received a copy of the GNU General Public License
 +along with this program.  If not, see <http://www.gnu.org/licenses/>.
 +
 +As a special exception, if you incorporate even large parts of the
 +code of this demo program into another program with substantially
 +different functionality, this does not cause the other program to
 +be covered by the GNU General Public License. This exception does
 +not however invalidate any other reasons why it might be covered
 +by the GNU General Public License. }
 +
 +{$gnu-pascal,I+}
 +
 +(* second style of comment *)
 +// Free-pascal style comment.
 +var x:Char = 12 /* 45;   // This /* does not start a comment.
 +var x:Char = (/ 4);      // This (/ does not start a comment.
 +var a_to_b : integer;    // 'to' should not be highlighted
 +
 +program CRTDemo;
 +
 +uses GPC, CRT;
 +
 +type
 +   TFrameChars = array [1 .. 8] of Char;
 +   TSimulateBlockCursorKind = (bc_None, bc_Blink, bc_Static);
 +
 +const
 +   SingleFrame: TFrameChars = (chCornerTLS, chLineHS, chCornerTRS, chLineVS, chLineVS, chCornerBLS, chLineHS, chCornerBRS);
 +   DoubleFrame: TFrameChars = (chCornerTLD, chLineHD, chCornerTRD, chLineVD, chLineVD, chCornerBLD, chLineHD, chCornerBRD);
 +
 +var
 +   ScrollState: Boolean = True;
 +   SimulateBlockCursorKind: TSimulateBlockCursorKind = bc_None;
 +   CursorShape: TCursorShape = CursorNormal;
 +   MainPanel: TPanel;
 +   OrigScreenSize: TPoint;
 +
 +procedure FrameWin (const Title: String; const Frame: TFrameChars; TitleInverse: Boolean);
 +var
 +   w, h, y, Color: Integer;
 +   Attr: TTextAttr;
 +begin
 +   HideCursor;
 +   SetPCCharSet (True);
 +   ClrScr;
 +   w := GetXMax;
 +   h := GetYMax;
 +   WriteCharAt (1, 1, 1,     Frame[1], TextAttr);
 +   WriteCharAt (2, 1, w - 2, Frame[2], TextAttr);
 +   WriteCharAt (w, 1, 1,     Frame[3], TextAttr);
 +   for y := 2 to h - 1 do
 +   begin
 +      WriteCharAt (1, y, 1, Frame[4], TextAttr);
 +      WriteCharAt (w, y, 1, Frame[5], TextAttr)
 +   end;
 +   WriteCharAt (1, h, 1,     Frame[6], TextAttr);
 +   WriteCharAt (2, h, w - 2, Frame[7], TextAttr);
 +   WriteCharAt (w, h, 1,     Frame[8], TextAttr);
 +   SetPCCharSet (False);
 +   Attr := TextAttr;
 +   if TitleInverse then
 +   begin
 +      Color := GetTextColor;
 +      TextColor (GetTextBackground);
 +      TextBackground (Color)
 +   end;
 +   WriteStrAt ((w - Length (Title)) div 2 + 1, 1, Title, TextAttr);
 +   TextAttr := Attr
 +end;
 +
 +function GetKey (TimeOut: Integer) = Key: TKey; forward;
 +
 +procedure ClosePopUpWindow;
 +begin
 +   PanelDelete (GetActivePanel);
 +   PanelDelete (GetActivePanel)
 +end;
 +
 +function PopUpConfirm (XSize, YSize: Integer; const Msg: String): Boolean;
 +var
 +   ax, ay: Integer;
 +   Key: TKey;
 +   SSize: TPoint;
 +begin
 +   repeat
 +      SSize := ScreenSize;
 +      ax := (SSize.x - XSize - 4) div 2 + 1;
 +      ay := (SSize.y - YSize - 4) div 2 + 1;
 +      PanelNew (ax, ay, ax + XSize + 3, ay + YSize + 1, False);
 +      TextBackground (Black);
 +      TextColor (Yellow);
 +      SetControlChars (True);
 +      FrameWin ('', DoubleFrame, False);
 +      NormalCursor;
 +      PanelNew (ax + 2, ay + 1, ax + XSize + 2, ay + YSize, False);
 +      ClrScr;
 +      Write (Msg);
 +      Key := GetKey (-1);
 +      if Key = kbScreenSizeChanged then ClosePopUpWindow
 +      until Key <> kbScreenSizeChanged;
 +   PopUpConfirm := not (Key in [kbEsc, kbAltEsc])
 +end;
 +
 +procedure MainDraw;
 +begin
 +   WriteLn ('3, F3 : Open a window');
 +   WriteLn ('4, F4 : Close window');
 +   WriteLn ('5, F5 : Previous window');
 +   WriteLn ('6, F6 : Next window');
 +   WriteLn ('7, F7 : Move window');
 +   WriteLn ('8, F8 : Resize window');
 +   Write   ('q, Esc: Quit')
 +end;
 +
 +procedure StatusDraw;
 +const
 +   YesNo: array [Boolean] of String [3] = ('No', 'Yes');
 +   SimulateBlockCursorIDs: array [TSimulateBlockCursorKind] of String [8] = ('Off', 'Blinking', 'Static');
 +   CursorShapeIDs: array [TCursorShape] of String [7] = ('Ignored', 'Hidden', 'Normal', 'Fat', 'Block');
 +var
 +   SSize: TPoint;
 +begin
 +   WriteLn ('You can change some of the following');
 +   WriteLn ('settings  by pressing the key  shown');
 +   WriteLn ('in parentheses. Naturally, color and');
 +   WriteLn ('changing the cursor  shape or screen');
 +   WriteLn ('size does not work on all terminals.');
 +   WriteLn;
 +   WriteLn ('XCurses version:          ', YesNo[XCRT]);
 +   WriteLn ('CRTSavePreviousScreen:    ', YesNo[CRTSavePreviousScreenWorks]);
 +   WriteLn ('(M)onochrome:             ', YesNo[IsMonochrome]);
 +   SSize := ScreenSize;
 +   WriteLn ('Screen (C)olumns:         ', SSize.x);
 +   WriteLn ('Screen (L)ines:           ', SSize.y);
 +   WriteLn ('(R)estore screen size');
 +   WriteLn ('(B)reak checking:         ', YesNo[CheckBreak]);
 +   WriteLn ('(S)crolling:              ', YesNo[ScrollState]);
 +   WriteLn ('S(i)mulated block cursor: ', SimulateBlockCursorIDs[SimulateBlockCursorKind]);
 +   Write   ('C(u)rsor shape:           ', CursorShapeIDs[CursorShape]);
 +   GotoXY (36, WhereY)
 +end;
 +
 +procedure RedrawAll; forward;
 +procedure CheckScreenSize; forward;
 +
 +procedure StatusKey (Key: TKey);
 +var SSize, NewSize: TPoint;
 +begin
 +   case LoCase (Key2Char (Key)) of
 +     'm': begin
 +	SetMonochrome (not IsMonochrome);
 +	RedrawAll
 +     end;
 +     'c': begin
 +	SSize := ScreenSize;
 +	if SSize.x > 40 then
 +	   NewSize.x := 40
 +	else
 +	   NewSize.x := 80;
 +	if SSize.y > 25 then
 +	   NewSize.y := 50
 +	else
 +	   NewSize.y := 25;
 +	SetScreenSize (NewSize.x, NewSize.y);
 +	CheckScreenSize
 +     end;
 +     'l': begin
 +	SSize := ScreenSize;
 +	if SSize.x > 40 then
 +	   NewSize.x := 80
 +	else
 +	   NewSize.x := 40;
 +	if SSize.y > 25 then
 +	   NewSize.y := 25
 +	else
 +	   NewSize.y := 50;
 +	SetScreenSize (NewSize.x, NewSize.y);
 +	CheckScreenSize
 +     end;
 +     'r': begin
 +	SetScreenSize (OrigScreenSize.x, OrigScreenSize.y);
 +	CheckScreenSize
 +     end;
 +     'b': CheckBreak := not CheckBreak;
 +     's': ScrollState := not ScrollState;
 +     'i': if SimulateBlockCursorKind = High (SimulateBlockCursorKind) then
 +	SimulateBlockCursorKind := Low (SimulateBlockCursorKind)
 +     else
 +	Inc (SimulateBlockCursorKind);
 +     'u': case CursorShape of
 +       CursorNormal: CursorShape := CursorBlock;
 +       CursorFat,
 +       CursorBlock : CursorShape := CursorHidden;
 +     else          CursorShape := CursorNormal
 +     end;
 +   end;
 +   ClrScr;
 +   StatusDraw
 +end;
 +
 +procedure TextAttrDemo;
 +var f, b, y, x1, y1, x2, y2, Fill, n1, n2, n3: Integer;
 +begin
 +   GetWindow (x1, y1, x2, y2);
 +   Window (x1 - 1, y1, x2, y2);
 +   TextColor (White);
 +   TextBackground (Blue);
 +   ClrScr;
 +   SetScroll (False);
 +   Fill := GetXMax - 32;
 +   for y := 1 to GetYMax do
 +   begin
 +      GotoXY (1, y);
 +      b := (y - 1) mod 16;
 +      n1 := 0;
 +      for f := 0 to 15 do
 +      begin
 +	 TextAttr := f + 16 * b;
 +	 n2 := (Fill * (1 + 2 * f) + 16) div 32;
 +	 n3 := (Fill * (2 + 2 * f) + 16) div 32;
 +	 Write ('' : n2 - n1, NumericBaseDigitsUpper[b], NumericBaseDigitsUpper[f], '' : n3 - n2);
 +	 n1 := n3
 +      end
 +   end
 +end;
 +
 +procedure CharSetDemo (UsePCCharSet: Boolean);
 +var h, l, y, x1, y1, x2, y2, Fill, n1, n2: Integer;
 +begin
 +   GetWindow (x1, y1, x2, y2);
 +   Window (x1 - 1, y1, x2, y2);
 +   ClrScr;
 +   SetScroll (False);
 +   SetPCCharSet (UsePCCharSet);
 +   SetControlChars (False);
 +   Fill := GetXMax - 35;
 +   for y := 1 to GetYMax do
 +   begin
 +      GotoXY (1, y);
 +      h := (y - 2) mod 16;
 +      n1 := (Fill + 9) div 18;
 +      if y = 1 then
 +	 Write ('' : 3 + n1)
 +      else
 +	 Write (16 * h : 3 + n1);
 +      for l := 0 to 15 do
 +      begin
 +	 n2 := (Fill * (2 + l) + 9) div 18;
 +	 if y = 1 then
 +	    Write ('' : n2 - n1, l : 2)
 +	 else
 +	    Write ('' : n2 - n1 + 1, Chr (16 * h + l));
 +	 n1 := n2
 +      end
 +   end
 +end;
 +
 +procedure NormalCharSetDemo;
 +begin
 +   CharSetDemo (False)
 +end;
 +
 +procedure PCCharSetDemo;
 +begin
 +   CharSetDemo (True)
 +end;
 +
 +procedure FKeyDemoDraw;
 +var x1, y1, x2, y2: Integer;
 +begin
 +   GetWindow (x1, y1, x2, y2);
 +   Window (x1, y1, x2 - 1, y2);
 +   ClrScr;
 +   SetScroll (False);
 +   WriteLn ('You can type the following keys');
 +   WriteLn ('(function keys if present on the');
 +   WriteLn ('terminal, letters as alternatives):');
 +   GotoXY (1, 4);
 +   WriteLn ('S, Left     : left (wrap-around)');
 +   WriteLn ('D, Right    : right (wrap-around)');
 +   WriteLn ('E, Up       : up (wrap-around)');
 +   WriteLn ('X, Down     : down (wrap-around)');
 +   WriteLn ('A, Home     : go to first column');
 +   WriteLn ('F, End      : go to last column');
 +   WriteLn ('R, Page Up  : go to first line');
 +   WriteLn ('C, Page Down: go to last line');
 +   WriteLn ('Y, Ctrl-PgUp: first column and line');
 +   GotoXY (1, 13);
 +   WriteLn ('B, Ctrl-PgDn: last column and line');
 +   WriteLn ('Z, Ctrl-Home: clear screen');
 +   WriteLn ('N, Ctrl-End : clear to end of line');
 +   WriteLn ('V, Insert   : insert a line');
 +   WriteLn ('T, Delete   : delete a line');
 +   WriteLn ('#           : beep');
 +   WriteLn ('*           : flash');
 +   WriteLn ('Tab, Enter, Backspace, other');
 +   WriteLn ('  normal characters: write text')
 +end;
 +
 +procedure FKeyDemoKey (Key: TKey);
 +const TabSize = 8;
 +var
 +   ch: Char;
 +   NewX: Integer;
 +begin
 +   case LoCaseKey (Key) of
 +     Ord ('s'), kbLeft    : if WhereX = 1 then GotoXY (GetXMax, WhereY) else GotoXY (WhereX - 1, WhereY);
 +     Ord ('d'), kbRight   : if WhereX = GetXMax then GotoXY (1, WhereY) else GotoXY (WhereX + 1, WhereY);
 +     Ord ('e'), kbUp      : if WhereY = 1 then GotoXY (WhereX, GetYMax) else GotoXY (WhereX, WhereY - 1);
 +     Ord ('x'), kbDown    : if WhereY = GetYMax then GotoXY (WhereX, 1) else GotoXY (WhereX, WhereY + 1);
 +     Ord ('a'), kbHome    : Write (chCR);
 +     Ord ('f'), kbEnd     : GotoXY (GetXMax, WhereY);
 +     Ord ('r'), kbPgUp    : GotoXY (WhereX, 1);
 +     Ord ('c'), kbPgDn    : GotoXY (WhereX, GetYMax);
 +     Ord ('y'), kbCtrlPgUp: GotoXY (1, 1);
 +     Ord ('b'), kbCtrlPgDn: GotoXY (GetXMax, GetYMax);
 +     Ord ('z'), kbCtrlHome: ClrScr;
 +     Ord ('n'), kbCtrlEnd : ClrEOL;
 +     Ord ('v'), kbIns     : InsLine;
 +     Ord ('t'), kbDel     : DelLine;
 +     Ord ('#')            : Beep;
 +     Ord ('*')            : Flash;
 +     kbTab                : begin
 +			       NewX := ((WhereX - 1) div TabSize + 1) * TabSize + 1;
 +			       if NewX <= GetXMax then GotoXY (NewX, WhereY) else WriteLn
 +			    end;
 +     kbCR                 : WriteLn;
 +     kbBkSp               : Write (chBkSp, ' ', chBkSp);
 +   else                   ch := Key2Char (Key);
 +     if ch <> #0 then Write (ch)
 +   end
 +end;
 +
 +procedure KeyDemoDraw;
 +begin
 +   WriteLn ('Press some keys ...')
 +end;
 +
 +procedure KeyDemoKey (Key: TKey);
 +var ch: Char;
 +begin
 +   ch := Key2Char (Key);
 +   if ch <> #0 then
 +   begin
 +      Write ('Normal key');
 +      if IsPrintable (ch) then Write (' `', ch, '''');
 +      WriteLn (', ASCII #', Ord (ch))
 +   end
 +   else
 +      WriteLn ('Special key ', Ord (Key2Scan (Key)))
 +end;
 +
 +procedure IOSelectPeriodical;
 +var
 +   CurrentTime: TimeStamp;
 +   s: String (8);
 +   i: Integer;
 +begin
 +   GetTimeStamp (CurrentTime);
 +   with CurrentTime do
 +      WriteStr (s, Hour : 2, ':', Minute : 2, ':', Second : 2);
 +   for i := 1 to Length (s) do
 +      if s[i] = ' ' then s[i] := '0';
 +   GotoXY (1, 12);
 +   Write ('The time is: ', s)
 +end;
 +
 +procedure IOSelectDraw;
 +begin
 +   WriteLn ('IOSelect is a way to handle I/O from');
 +   WriteLn ('or to several places simultaneously,');
 +   WriteLn ('without  having  to use  threads  or');
 +   WriteLn ('signal/interrupt  handlers  or waste');
 +   WriteLn ('CPU time with busy waiting.');
 +   WriteLn;
 +   WriteLn ('This demo  shows how  IOSelect works');
 +   WriteLn ('in connection with CRT.  It displays');
 +   WriteLn ('a clock,  but still  reacts  to user');
 +   WriteLn ('input immediately.');
 +   IOSelectPeriodical
 +end;
 +
 +procedure ModifierPeriodical;
 +const
 +   Pressed: array [Boolean] of String [8] = ('Released', 'Pressed');
 +   ModifierNames: array [1 .. 7] of record
 +		     Modifier: Integer;
 +		     Name: String (17)
 +		  end =
 +   ((shLeftShift,  'Left Shift'),
 +    (shRightShift, 'Right Shift'),
 +    (shLeftCtrl,   'Left Control'),
 +    (shRightCtrl,  'Right Control'),
 +    (shAlt,        'Alt (left)'),
 +    (shAltGr,      'AltGr (right Alt)'),
 +    (shExtra,      'Extra'));
 +var
 +   ShiftState, i: Integer;
 +begin
 +   ShiftState := GetShiftState;
 +   for i := 1 to 7 do
 +      with ModifierNames[i] do
 +      begin
 +	 GotoXY (1, 4 + i);
 +	 ClrEOL;
 +	 Write (Name, ':');
 +	 GotoXY (20, WhereY);
 +	 Write (Pressed[(ShiftState and Modifier) <> 0])
 +      end
 +end;
 +
 +procedure ModifierDraw;
 +begin
 +   WriteLn ('Modifier keys (NOTE: only');
 +   WriteLn ('available on some systems;');
 +   WriteLn ('X11: only after key press):');
 +   ModifierPeriodical
 +end;
 +
 +procedure ChecksDraw;
 +begin
 +   WriteLn ('(O)S shell');
 +   WriteLn ('OS shell with (C)learing');
 +   WriteLn ('(R)efresh check');
 +   Write   ('(S)ound check')
 +end;
 +
 +procedure ChecksKey (Key: TKey);
 +var
 +   i, j: Integer;
 +   WasteTime: Real; attribute (volatile);
 +
 +   procedure DoOSShell;
 +   var
 +      Result: Integer;
 +      Shell: TString;
 +   begin
 +      Shell := GetShellPath (Null);
 +      {$I-}
 +      Result := Execute (Shell);
 +      {$I+}
 +      if (InOutRes <> 0) or (Result <> 0) then
 +      begin
 +	 ClrScr;
 +	 if InOutRes <> 0 then
 +	    WriteLn (GetIOErrorMessage, ' while trying to execute `', Shell, '''.')
 +	 else
 +	    WriteLn ('`', Shell, ''' returned status ', Result, '.');
 +	 Write ('Any key to continue.');
 +	 BlockCursor;
 +	 Discard (GetKey (-1))
 +      end
 +   end;
 +
 +begin
 +   case LoCase (Key2Char (Key)) of
 +     'o': begin
 +	if PopUpConfirm (36, 12, 'You will now get an OS shell. Unless' + NewLine +
 +			 'CRTDemo is running  in its own (GUI)' + NewLine +
 +			 'window,  the shell  will run  on the' + NewLine +
 +			 'same screen as CRTDemo  which is not' + NewLine +
 +			 'cleared before the shell is started.' + NewLine +
 +			 'If possible, the screen contents are' + NewLine +
 +			 'restored to the state before CRTDemo' + NewLine +
 +			 'was started. After leaving the shell' + NewLine +
 +			 'in the usual way (usually  by enter-' + NewLine +
 +			 'ing  `exit''), you will  get back to' + NewLine +
 +			 'the demo.  <ESC> to abort, any other' + NewLine +
 +			 'key to start.') then
 +	begin
 +	   RestoreTerminal (True);
 +	   DoOSShell
 +	end;
 +	ClosePopUpWindow
 +     end;
 +     'c': begin
 +	if PopUpConfirm (36, 9, 'You will now get an OS shell. Unless' + NewLine +
 +			 'CRTDemo is running in  its own (GUI)' + NewLine +
 +			 'window, the screen  will be cleared,' + NewLine +
 +			 'and the cursor will be  moved to the' + NewLine +
 +			 'top  before  the  shell  is started.' + NewLine +
 +			 'After leaving the shell in the usual' + NewLine +
 +			 'way  (usually  by entering  `exit''),' + NewLine +
 +			 'you will get back to the demo. <ESC>' + NewLine +
 +			 'to abort, any other key to start.') then
 +	begin
 +	   RestoreTerminalClearCRT;
 +	   DoOSShell
 +	end;
 +	ClosePopUpWindow
 +     end;
 +     'r': begin
 +	if PopUpConfirm (36, 11, 'The program will  now get  busy with' + NewLine +
 +			 'some  dummy  computations.  However,' + NewLine +
 +			 'CRT output in  the form of dots will' + NewLine +
 +			 'still appear continuously one by one' + NewLine +
 +			 '(rather than the  whole line at once' + NewLine +
 +			 'in the end). While running, the test' + NewLine +
 +			 'cannot  be  interrupted.   <ESC>  to' + NewLine +
 +			 'abort, any other key to start.') then
 +	begin
 +	   SetCRTUpdate (UpdateRegularly);
 +	   BlockCursor;
 +	   WriteLn;
 +	   WriteLn;
 +	   for i := 1 to GetXMax - 2 do
 +	   begin
 +	      Write ('.');
 +	      for j := 1 to 400000 do WasteTime := Random
 +	   end;
 +	   SetCRTUpdate (UpdateInput);
 +	   WriteLn;
 +	   Write ('Press any key.');
 +	   Discard (GetKey (-1))
 +	end;
 +	ClosePopUpWindow
 +     end;
 +     's': begin
 +	if PopUpConfirm (32, 4, 'You will now hear some sounds if' + NewLine +
 +			 'supported  (otherwise there will' + NewLine +
 +			 'just be a short pause). <ESC> to' + NewLine +
 +			 'abort, any other key to start.') then
 +	begin
 +	   BlockCursor;
 +	   for i := 0 to 7 do
 +	   begin
 +	      Sound (Round (440 * 2 ** (Round (i * 12 / 7 + 0.3) / 12)));
 +	      if GetKey (400000) in [kbEsc, kbAltEsc] then Break
 +	   end;
 +	   NoSound
 +	end;
 +	ClosePopUpWindow
 +     end;
 +   end
 +end;
 +
 +type
 +   PWindowList = ^TWindowList;
 +   TWindowList = record
 +		    Next, Prev: PWindowList;
 +		    Panel, FramePanel: TPanel;
 +		    WindowType: Integer;
 +		    x1, y1, xs, ys: Integer;
 +		    State: (ws_None, ws_Moving, ws_Resizing);
 +		 end;
 +
 +TKeyProc = procedure (Key: TKey);
 +TProcedure = procedure;
 +
 +const
 +   MenuNameLength = 16;
 +   WindowTypes: array [0 .. 9] of record
 +		   DrawProc,
 +		   PeriodicalProc: procedure;
 +		   KeyProc       : TKeyProc;
 +		   Name          : String (MenuNameLength);
 +		   Color,
 +		   Background,
 +		   MinSizeX,
 +		   MinSizeY,
 +		   PrefSizeX,
 +		   PrefSizeY     : Integer;
 +		   RedrawAlways,
 +		   WantCursor    : Boolean
 +				   end =
 +((MainDraw         , nil               , nil        , 'CRT Demo'        , LightGreen, Blue     , 26,  7,  0,  0, False, False),
 + (StatusDraw       , nil               , StatusKey  , 'Status'          , White     , Red      , 38, 16,  0,  0, True,  True),
 + (TextAttrDemo     , nil               , nil        , 'Text Attributes' , White     , Blue     , 32, 16, 64, 16, False, False),
 + (NormalCharSetDemo, nil               , nil        , 'Character Set'   , Black     , Green    , 35, 17, 53, 17, False, False),
 + (PCCharSetDemo    , nil               , nil        , 'PC Character Set', Black     , Brown    , 35, 17, 53, 17, False, False),
 + (KeyDemoDraw      , nil               , KeyDemoKey , 'Keys'            , Blue      , LightGray, 29,  5, -1, -1, False, True),
 + (FKeyDemoDraw     , nil               , FKeyDemoKey, 'Function Keys'   , Blue      , LightGray, 37, 22, -1, -1, False, True),
 + (ModifierDraw     , ModifierPeriodical, nil        , 'Modifier Keys'   , Black     , Cyan     , 29, 11,  0,  0, True,  False),
 + (IOSelectDraw     , IOSelectPeriodical, nil        , 'IOSelect Demo'   , White     , Magenta  , 38, 12,  0,  0, False, False),
 + (ChecksDraw       , nil               , ChecksKey  , 'Various Checks'  , Black     , Red      , 26,  4,  0,  0, False, False));
 +
 +MenuMax = High (WindowTypes);
 +MenuXSize = MenuNameLength + 4;
 +MenuYSize = MenuMax + 2;
 +
 +var
 +   WindowList: PWindowList = nil;
 +
 +   procedure RedrawFrame (p: PWindowList);
 +   begin
 +      with p^, WindowTypes[WindowType] do
 +      begin
 +	 PanelActivate (FramePanel);
 +	 Window (x1, y1, x1 + xs - 1, y1 + ys - 1);
 +	 ClrScr;
 +	 case State of
 +	   ws_None    : if p = WindowList then
 +	      FrameWin (' ' + Name + ' ', DoubleFrame, True)
 +	   else
 +	      FrameWin (' ' + Name + ' ', SingleFrame, False);
 +	   ws_Moving  : FrameWin (' Move Window ', SingleFrame, True);
 +	   ws_Resizing: FrameWin (' Resize Window ', SingleFrame, True);
 +	 end
 +      end
 +   end;
 +
 +   procedure DrawWindow (p: PWindowList);
 +   begin
 +      with p^, WindowTypes[WindowType] do
 +      begin
 +	 RedrawFrame (p);
 +	 PanelActivate (Panel);
 +	 Window (x1 + 2, y1 + 1, x1 + xs - 2, y1 + ys - 2);
 +	 ClrScr;
 +	 DrawProc
 +      end
 +   end;
 +
 +   procedure RedrawAll;
 +   var
 +      LastPanel: TPanel;
 +      p: PWindowList;
 +      x2, y2: Integer;
 +   begin
 +      LastPanel := GetActivePanel;
 +      PanelActivate (MainPanel);
 +      TextBackground (Blue);
 +      ClrScr;
 +      p := WindowList;
 +      if p <> nil then
 +	 repeat
 +	    with p^ do
 +	    begin
 +	       PanelActivate (FramePanel);
 +	       GetWindow (x1, y1, x2, y2);  { updated automatically by CRT }
 +	       xs := x2 - x1 + 1;
 +	       ys := y2 - y1 + 1
 +	    end;
 +	    DrawWindow (p);
 +	    p := p^.Next
 +	 until p = WindowList;
 +      PanelActivate (LastPanel)
 +   end;
 +
 +   procedure CheckScreenSize;
 +   var
 +      LastPanel: TPanel;
 +      MinScreenSizeX, MinScreenSizeY, i: Integer;
 +      SSize: TPoint;
 +   begin
 +      LastPanel := GetActivePanel;
 +      PanelActivate (MainPanel);
 +      HideCursor;
 +      MinScreenSizeX := MenuXSize;
 +      MinScreenSizeY := MenuYSize;
 +      for i := Low (WindowTypes) to High (WindowTypes) do
 +	 with WindowTypes[i] do
 +	 begin
 +	    MinScreenSizeX := Max (MinScreenSizeX, MinSizeX + 2);
 +	    MinScreenSizeY := Max (MinScreenSizeY, MinSizeY + 2)
 +	 end;
 +      SSize := ScreenSize;
 +      Window (1, 1, SSize.x, SSize.y);
 +      if (SSize.x < MinScreenSizeX) or (SSize.y < MinScreenSizeY) then
 +      begin
 +	 NormVideo;
 +	 ClrScr;
 +	 RestoreTerminal (True);
 +	 WriteLn (StdErr, 'Sorry, your screen is too small for this demo (', SSize.x, 'x', SSize.y, ').');
 +	 WriteLn (StdErr, 'You need at least ', MinScreenSizeX, 'x', MinScreenSizeY, ' characters.');
 +	 Halt (2)
 +      end;
 +      PanelActivate (LastPanel);
 +      RedrawAll
 +   end;
 +
 +   procedure Die; attribute (noreturn);
 +   begin
 +      NoSound;
 +      RestoreTerminalClearCRT;
 +      WriteLn (StdErr, 'You''re trying to kill me. Since I have break checking turned off,');
 +      WriteLn (StdErr, 'I''m not dying, but I''ll do you a favor and terminate now.');
 +      Halt (3)
 +   end;
 +
 +   function GetKey (TimeOut: Integer) = Key: TKey;
 +   var
 +      NeedSelect, SelectValue: Integer;
 +      SimulateBlockCursorCurrent: TSimulateBlockCursorKind;
 +      SelectInput: array [1 .. 1] of PAnyFile = (@Input);
 +      NextSelectTime: MicroSecondTimeType = 0; attribute (static);
 +      TimeOutTime: MicroSecondTimeType;
 +      LastPanel: TPanel;
 +      p: PWindowList;
 +   begin
 +      LastPanel := GetActivePanel;
 +      if TimeOut < 0 then
 +	 TimeOutTime := High (TimeOutTime)
 +      else
 +	 TimeOutTime := GetMicroSecondTime + TimeOut;
 +      NeedSelect := 0;
 +      if TimeOut >= 0 then
 +	 Inc (NeedSelect);
 +      SimulateBlockCursorCurrent := SimulateBlockCursorKind;
 +      if SimulateBlockCursorCurrent <> bc_None then
 +	 Inc (NeedSelect);
 +      p := WindowList;
 +      repeat
 +	 if @WindowTypes[p^.WindowType].PeriodicalProc <> nil then
 +	    Inc (NeedSelect);
 +	 p := p^.Next
 +      until p = WindowList;
 +      p := WindowList;
 +      repeat
 +	 with p^, WindowTypes[WindowType] do
 +	    if RedrawAlways then
 +	    begin
 +	       PanelActivate (Panel);
 +	       ClrScr;
 +	       DrawProc
 +	    end;
 +	 p := p^.Next
 +      until p = WindowList;
 +      if NeedSelect <> 0 then
 +	 repeat
 +	    CRTUpdate;
 +	    SelectValue := IOSelectRead (SelectInput, Max (0, Min (NextSelectTime, TimeOutTime) - GetMicroSecondTime));
 +	    if SelectValue = 0 then
 +	    begin
 +	       case SimulateBlockCursorCurrent of
 +		 bc_None  : ;
 +		 bc_Blink : SimulateBlockCursor;
 +		 bc_Static: begin
 +		    SimulateBlockCursor;
 +		    SimulateBlockCursorCurrent := bc_None;
 +		    Dec (NeedSelect)
 +		 end
 +	       end;
 +	       NextSelectTime := GetMicroSecondTime + 120000;
 +	       p := WindowList;
 +	       repeat
 +		  with p^, WindowTypes[WindowType] do
 +		     if @PeriodicalProc <> nil then
 +		     begin
 +			PanelActivate (Panel);
 +			PeriodicalProc
 +		     end;
 +		  p := p^.Next
 +	       until p = WindowList
 +	    end;
 +	 until (NeedSelect = 0) or (SelectValue <> 0) or ((TimeOut >= 0) and (GetMicroSecondTime >= TimeOutTime));
 +      if NeedSelect = 0 then
 +	 SelectValue := 1;
 +      if SelectValue = 0 then
 +	 Key := 0
 +      else
 +	 Key := ReadKeyWord;
 +      if SimulateBlockCursorKind <> bc_None then
 +	 SimulateBlockCursorOff;
 +      if IsDeadlySignal (Key) then Die;
 +      if Key = kbScreenSizeChanged then CheckScreenSize;
 +      PanelActivate (LastPanel)
 +   end;
 +
 +   function Menu = n: Integer;
 +   var
 +      i, ax, ay: Integer;
 +      Key: TKey;
 +      Done: Boolean;
 +      SSize: TPoint;
 +   begin
 +      n := 1;
 +      repeat
 +	 SSize := ScreenSize;
 +	 ax := (SSize.x - MenuXSize) div 2 + 1;
 +	 ay := (SSize.y - MenuYSize) div 2 + 1;
 +	 PanelNew (ax, ay, ax + MenuXSize - 1, ay + MenuYSize - 1, False);
 +	 SetControlChars (True);
 +	 TextColor (Blue);
 +	 TextBackground (LightGray);
 +	 FrameWin (' Select Window ', DoubleFrame, True);
 +	 IgnoreCursor;
 +	 PanelNew (ax + 1, ay + 1, ax + MenuXSize - 2, ay + MenuYSize - 2, False);
 +	 ClrScr;
 +	 TextColor (Black);
 +	 SetScroll (False);
 +	 Done := False;
 +	 repeat
 +	    for i := 1 to MenuMax do
 +	    begin
 +	       GotoXY (1, i);
 +	       if i = n then
 +		  TextBackground (Green)
 +	       else
 +		  TextBackground (LightGray);
 +	       ClrEOL;
 +	       Write (' ', WindowTypes[i].Name);
 +	       ChangeTextAttr (2, i, 1, Red + $10 * GetTextBackground)
 +	    end;
 +	    Key := GetKey (-1);
 +	    case LoCaseKey (Key) of
 +	      kbUp                  : if n = 1 then n := MenuMax else Dec (n);
 +	      kbDown                : if n = MenuMax then n := 1 else Inc (n);
 +	      kbHome,
 +	      kbPgUp,
 +	      kbCtrlPgUp,
 +	      kbCtrlHome            : n := 1;
 +	      kbEnd,
 +	      kbPgDn,
 +	      kbCtrlPgDn,
 +	      kbCtrlEnd             : n := MenuMax;
 +	      kbCR                  : Done := True;
 +	      kbEsc, kbAltEsc       : begin
 +		 n := -1;
 +		 Done := True
 +	      end;
 +	      Ord ('a') .. Ord ('z'): begin
 +		 i := MenuMax;
 +		 while (i > 0) and (LoCase (Key2Char (Key)) <> LoCase (WindowTypes[i].Name[1])) do Dec (i);
 +		 if i > 0 then
 +		 begin
 +		    n := i;
 +		    Done := True
 +		 end
 +	      end;
 +	    end
 +	 until Done or (Key = kbScreenSizeChanged);
 +	 ClosePopUpWindow
 +      until Key <> kbScreenSizeChanged
 +   end;
 +
 +   procedure NewWindow (WindowType, ax, ay: Integer);
 +   var
 +      p, LastWindow: PWindowList;
 +      MaxX1, MaxY1: Integer;
 +      SSize: TPoint;
 +   begin
 +      New (p);
 +      if WindowList = nil then
 +      begin
 +	 p^.Prev := p;
 +	 p^.Next := p
 +      end
 +      else
 +      begin
 +	 p^.Prev := WindowList;
 +	 p^.Next := WindowList^.Next;
 +	 p^.Prev^.Next := p;
 +	 p^.Next^.Prev := p;
 +      end;
 +      p^.WindowType := WindowType;
 +      with p^, WindowTypes[WindowType] do
 +      begin
 +	 SSize := ScreenSize;
 +	 if PrefSizeX > 0 then xs := PrefSizeX else xs := MinSizeX;
 +	 if PrefSizeY > 0 then ys := PrefSizeY else ys := MinSizeY;
 +	 xs := Min (xs + 2, SSize.x);
 +	 ys := Min (ys + 2, SSize.y);
 +	 MaxX1 := SSize.x - xs + 1;
 +	 MaxY1 := SSize.y - ys + 1;
 +	 if ax = 0 then x1 := Random (MaxX1) + 1 else x1 := Min (ax, MaxX1);
 +	 if ay = 0 then y1 := Random (MaxY1) + 1 else y1 := Min (ay, MaxY1);
 +	 if (ax = 0) and (PrefSizeX < 0) then Inc (xs, Random (SSize.x - x1 - xs + 2));
 +	 if (ax = 0) and (PrefSizeY < 0) then Inc (ys, Random (SSize.y - y1 - ys + 2));
 +	 State := ws_None;
 +	 PanelNew (1, 1, 1, 1, False);
 +	 FramePanel := GetActivePanel;
 +	 SetControlChars (True);
 +	 TextColor (Color);
 +	 TextBackground (Background);
 +	 PanelNew (1, 1, 1, 1, False);
 +	 SetPCCharSet (False);
 +	 Panel := GetActivePanel;
 +      end;
 +      LastWindow := WindowList;
 +      WindowList := p;
 +      if LastWindow <> nil then RedrawFrame (LastWindow);
 +      DrawWindow (p)
 +   end;
 +
 +   procedure OpenWindow;
 +   var WindowType: Integer;
 +   begin
 +      WindowType := Menu;
 +      if WindowType >= 0 then NewWindow (WindowType, 0, 0)
 +   end;
 +
 +   procedure NextWindow;
 +   var LastWindow: PWindowList;
 +   begin
 +      LastWindow := WindowList;
 +      WindowList := WindowList^.Next;
 +      PanelTop (WindowList^.FramePanel);
 +      PanelTop (WindowList^.Panel);
 +      RedrawFrame (LastWindow);
 +      RedrawFrame (WindowList)
 +   end;
 +
 +   procedure PreviousWindow;
 +   var LastWindow: PWindowList;
 +   begin
 +      PanelMoveAbove (WindowList^.Panel, MainPanel);
 +      PanelMoveAbove (WindowList^.FramePanel, MainPanel);
 +      LastWindow := WindowList;
 +      WindowList := WindowList^.Prev;
 +      RedrawFrame (LastWindow);
 +      RedrawFrame (WindowList)
 +   end;
 +
 +   procedure CloseWindow;
 +   var p: PWindowList;
 +   begin
 +      if WindowList^.WindowType <> 0 then
 +      begin
 +	 p := WindowList;
 +	 NextWindow;
 +	 PanelDelete (p^.FramePanel);
 +	 PanelDelete (p^.Panel);
 +	 p^.Next^.Prev := p^.Prev;
 +	 p^.Prev^.Next := p^.Next;
 +	 Dispose (p)
 +      end
 +   end;
 +
 +   procedure MoveWindow;
 +   var
 +      Done, Changed: Boolean;
 +      SSize: TPoint;
 +   begin
 +      with WindowList^ do
 +      begin
 +	 Done := False;
 +	 Changed := True;
 +	 State := ws_Moving;
 +	 repeat
 +	    if Changed then DrawWindow (WindowList);
 +	    Changed := True;
 +	    case LoCaseKey (GetKey (-1)) of
 +	      Ord ('s'), kbLeft    : if x1 > 1 then Dec (x1);
 +	      Ord ('d'), kbRight   : if x1 + xs - 1 < ScreenSize.x then Inc (x1);
 +	      Ord ('e'), kbUp      : if y1 > 1 then Dec (y1);
 +	      Ord ('x'), kbDown    : if y1 + ys - 1 < ScreenSize.y then Inc (y1);
 +	      Ord ('a'), kbHome    : x1 := 1;
 +	      Ord ('f'), kbEnd     : x1 := ScreenSize.x - xs + 1;
 +	      Ord ('r'), kbPgUp    : y1 := 1;
 +	      Ord ('c'), kbPgDn    : y1 := ScreenSize.y - ys + 1;
 +	      Ord ('y'), kbCtrlPgUp: begin
 +		 x1 := 1;
 +		 y1 := 1
 +	      end;
 +	      Ord ('b'), kbCtrlPgDn: begin
 +		 SSize := ScreenSize;
 +		 x1 := SSize.x - xs + 1;
 +		 y1 := SSize.y - ys + 1
 +	      end;
 +	      kbCR,
 +	      kbEsc, kbAltEsc      : Done := True;
 +	    else                   Changed := False
 +	    end
 +	 until Done;
 +	 State := ws_None;
 +	 DrawWindow (WindowList)
 +      end
 +   end;
 +
 +   procedure ResizeWindow;
 +   var
 +      Done, Changed: Boolean;
 +      SSize: TPoint;
 +   begin
 +      with WindowList^, WindowTypes[WindowType] do
 +      begin
 +	 Done := False;
 +	 Changed := True;
 +	 State := ws_Resizing;
 +	 repeat
 +	    if Changed then DrawWindow (WindowList);
 +	    Changed := True;
 +	    case LoCaseKey (GetKey (-1)) of
 +	      Ord ('s'), kbLeft    : if xs > MinSizeX + 2 then Dec (xs);
 +	      Ord ('d'), kbRight   : if x1 + xs - 1 < ScreenSize.x then Inc (xs);
 +	      Ord ('e'), kbUp      : if ys > MinSizeY + 2 then Dec (ys);
 +	      Ord ('x'), kbDown    : if y1 + ys - 1 < ScreenSize.y then Inc (ys);
 +	      Ord ('a'), kbHome    : xs := MinSizeX + 2;
 +	      Ord ('f'), kbEnd     : xs := ScreenSize.x - x1 + 1;
 +	      Ord ('r'), kbPgUp    : ys := MinSizeY + 2;
 +	      Ord ('c'), kbPgDn    : ys := ScreenSize.y - y1 + 1;
 +	      Ord ('y'), kbCtrlPgUp: begin
 +		 xs := MinSizeX + 2;
 +		 ys := MinSizeY + 2
 +	      end;
 +	      Ord ('b'), kbCtrlPgDn: begin
 +		 SSize := ScreenSize;
 +		 xs := SSize.x - x1 + 1;
 +		 ys := SSize.y - y1 + 1
 +	      end;
 +	      kbCR,
 +	      kbEsc, kbAltEsc      : Done := True;
 +	    else                   Changed := False
 +	    end
 +	 until Done;
 +	 State := ws_None;
 +	 DrawWindow (WindowList)
 +      end
 +   end;
 +
 +   procedure ActivateCursor;
 +   begin
 +      with WindowList^, WindowTypes[WindowType] do
 +      begin
 +	 PanelActivate (Panel);
 +	 if WantCursor then
 +	    SetCursorShape (CursorShape)
 +	 else
 +	    HideCursor
 +      end;
 +      SetScroll (ScrollState)
 +   end;
 +
 +var
 +   Key: TKey;
 +   ScreenShot, Done: Boolean;
 +
 +begin
 +   ScreenShot := ParamStr (1) = '--screenshot';
 +   if ParamCount <> Ord (ScreenShot) then
 +   begin
 +      RestoreTerminal (True);
 +      WriteLn (StdErr, ParamStr (0), ': invalid argument `', ParamStr (Ord (ScreenShot) + 1), '''');
 +      Halt (1)
 +   end;
 +   CRTSavePreviousScreen (True);
 +   SetCRTUpdate (UpdateInput);
 +   MainPanel := GetActivePanel;
 +   CheckScreenSize;
 +   OrigScreenSize := ScreenSize;
 +   if ScreenShot then
 +   begin
 +      CursorShape := CursorBlock;
 +      NewWindow (6,      1,      1);
 +      NewWindow (2,      1, MaxInt);
 +      NewWindow (8, MaxInt,      1);
 +      NewWindow (5,      1,     27);
 +      KeyDemoKey (Ord ('f'));
 +      KeyDemoKey (246);
 +      KeyDemoKey (kbDown);
 +      NewWindow (3, MaxInt,     13);
 +      NewWindow (4, MaxInt,     31);
 +      NewWindow (7, MaxInt, MaxInt);
 +      NewWindow (9, MaxInt,     33);
 +      NewWindow (0,      1,      2);
 +      NewWindow (1,      1,     14);
 +      ActivateCursor;
 +      OpenWindow
 +   end
 +   else
 +      NewWindow (0, 3, 2);
 +   Done := False;
 +   repeat
 +      ActivateCursor;
 +      Key := GetKey (-1);
 +      case LoCaseKey (Key) of
 +	Ord ('3'), kbF3 : OpenWindow;
 +	Ord ('4'), kbF4 : CloseWindow;
 +	Ord ('5'), kbF5 : PreviousWindow;
 +	Ord ('6'), kbF6 : NextWindow;
 +	Ord ('7'), kbF7 : MoveWindow;
 +	Ord ('8'), kbF8 : ResizeWindow;
 +	Ord ('q'), kbEsc,
 +	kbAltEsc:         Done := True;
 +      else
 +	 if WindowList <> nil then
 +	    with WindowList^, WindowTypes[WindowType] do
 +	       if @KeyProc <> nil then
 +	       begin
 +		  TextColor (Color);
 +		  TextBackground (Background);
 +		  KeyProc (Key)
 +	       end
 +      end
 +   until Done
 +end.
diff --cc test/manual/redisplay-testsuite.el
index 37a5649dc1b,00000000000..694d55ab1db
mode 100644,000000..100644
--- a/test/manual/redisplay-testsuite.el
+++ b/test/manual/redisplay-testsuite.el
@@@ -1,313 -1,0 +1,313 @@@
 +;;; redisplay-testsuite.el --- Test suite for redisplay.
 +
- ;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2009-2017 Free Software Foundation, Inc.
 +
 +;; Author: Chong Yidong <cyd@stupidchicken.com>
 +;; Keywords:       internal
 +;; Human-Keywords: internal
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 +
 +;;; Commentary:
 +
 +;; Type M-x test-redisplay RET to generate the test buffer.
 +
 +;;; Code:
 +
 +(defun test-insert-overlay (text &rest props)
 +  (let ((opoint (point))
 +	overlay)
 +    (insert text)
 +    (setq overlay (make-overlay opoint (point)))
 +    (while props
 +      (overlay-put overlay (car props) (cadr props))
 +      (setq props (cddr props)))))
 +
 +(defun test-redisplay-1 ()
 +  (insert "Test 1: Displaying adjacent and overlapping overlays:\n\n")
 +  (insert "  Expected: gnu emacs\n")
 +  (insert "  Results:  ")
 +  (test-insert-overlay "n" 'before-string "g" 'after-string  "u ")
 +  (test-insert-overlay "ma" 'before-string "e" 'after-string  "cs")
 +  (insert "\n\n")
 +  (insert "  Expected: gnu emacs\n")
 +  (insert "  Results:  ")
 +  (test-insert-overlay "u" 'before-string "gn")
 +  (test-insert-overlay "ma" 'before-string " e" 'after-string  "cs")
 +  (insert "\n\n")
 +  (insert "  Expected: gnu emacs\n")
 +  (insert "  Results:  ")
 +  (test-insert-overlay "XXX" 'display "u "
 +		       'before-string "gn" 'after-string  "em")
 +  (test-insert-overlay "a" 'after-string  "cs")
 +  (insert "\n\n")
 +  (insert "  Expected: gnu emacs\n")
 +  (insert "  Results:  ")
 +  (test-insert-overlay "u " 'before-string "gn" 'after-string  "em")
 +  (test-insert-overlay "XXX" 'display "a" 'after-string  "cs")
 +  (insert "\n\n"))
 +
 +(defun test-redisplay-2 ()
 +  (insert "Test 2: Mouse highlighting.  Move your mouse over the letters XXX:\n\n")
 +  (insert "  Expected: "
 +	  (propertize "xxxXXXxxx" 'face 'highlight)
 +	  "...---...\n  Test:     ")
 +  (test-insert-overlay "XXX" 'before-string "xxx" 'after-string  "xxx"
 +		       'mouse-face 'highlight )
 +  (test-insert-overlay "---" 'before-string "..." 'after-string  "...")
 +  (insert "\n\n  Expected: "
 +	  (propertize "xxxXXX" 'face 'highlight)
 +	  "...---...\n  Test:     ")
 +  (test-insert-overlay "XXX" 'before-string "xxx" 'mouse-face 'highlight)
 +  (test-insert-overlay "---" 'before-string "..." 'after-string  "...")
 +  (insert "\n\n  Expected: "
 +	  (propertize "XXX" 'face 'highlight)
 +	  "...---...\n  Test:     ")
 +  (test-insert-overlay "..." 'display "XXX" 'mouse-face 'highlight)
 +  (test-insert-overlay "---" 'before-string "..." 'after-string  "...")
 +  (insert "\n\n  Expected: "
 +	  (propertize "XXXxxx" 'face 'highlight)
 +	  "...\n  Test:     ")
 +  (test-insert-overlay "..." 'display "XXX" 'after-string "xxx"
 +		       'mouse-face 'highlight)
 +  (test-insert-overlay "error" 'display "...")
 +  (insert "\n\n  Expected: "
 +	  "---..."
 +	  (propertize "xxxXXX" 'face 'highlight)
 +	  "\n  Test:     ")
 +  (test-insert-overlay "xxx" 'display "---" 'after-string "...")
 +  (test-insert-overlay "error" 'before-string "xxx" 'display "XXX"
 +		       'mouse-face 'highlight)
 +  (insert "\n\n  Expected: "
 +	  "...---..."
 +	  (propertize "xxxXXXxxx" 'face 'highlight)
 +	  "\n  Test:     ")
 +  (test-insert-overlay "---" 'before-string "..." 'after-string  "...")
 +  (test-insert-overlay "XXX" 'before-string "xxx" 'after-string  "xxx"
 +		       'mouse-face 'highlight)
 +  (insert "\n\n  Expected: "
 +	  "..."
 +	  (propertize "XXX" 'face 'highlight)
 +	  "...\n  Test:     ")
 +  (test-insert-overlay "---"
 +		       'display (propertize "XXX" 'mouse-face 'highlight)
 +		       'before-string "..."
 +		       'after-string  "...")
 +  (insert "\n\n  Expected: "
 +	  (propertize "XXX\n" 'face 'highlight)
 +	  "\n  Test:     ")
 +  (test-insert-overlay "XXX\n" 'mouse-face 'highlight)
 +  (insert "\n\n"))
 +
 +(defun test-redisplay-3 ()
 +  (insert "Test 3: Overlay with strings and images:\n\n")
 +  (let ((img-data "#define x_width 8
 +#define x_height 8
 +static unsigned char x_bits[] = {0xff, 0x81, 0xbd, 0xa5, 0xa5, 0xbd, 0x81, 0xff };"))
 +    ;; Control
 +    (insert "  Expected: AB"
 +	    (propertize "X" 'display `(image :data ,img-data :type xbm))
 +	    "CD\n")
 +
 +    ;; Overlay with before, after, and image display string.
 +    (insert "  Result 1: ")
 +    (let ((opoint (point)))
 +      (insert "AXD\n")
 +      (let ((ov (make-overlay (1+ opoint) (+ 2 opoint))))
 +	(overlay-put ov 'before-string "B")
 +	(overlay-put ov 'after-string "C")
 +	(overlay-put ov 'display
 +		     `(image :data ,img-data :type xbm))))
 +
 +    ;; Overlay with before and after string, and image text prop.
 +    (insert "  Result 2: ")
 +    (let ((opoint (point)))
 +      (insert "AXD\n")
 +      (let ((ov (make-overlay (1+ opoint) (+ 2 opoint))))
 +	(overlay-put ov 'before-string "B")
 +	(overlay-put ov 'after-string "C")
 +	(put-text-property (1+ opoint) (+ 2 opoint) 'display
 +			   `(image :data ,img-data :type xbm))))
 +
 +    ;; Overlays with adjacent before and after strings, and image text
 +    ;; prop.
 +    (insert "  Result 3: ")
 +    (let ((opoint (point)))
 +      (insert "AXD\n")
 +      (let ((ov1 (make-overlay opoint (1+ opoint)))
 +	    (ov2 (make-overlay (+ 2 opoint) (+ 3 opoint))))
 +	(overlay-put ov1 'after-string "B")
 +	(overlay-put ov2 'before-string "C")
 +	(put-text-property (1+ opoint) (+ 2 opoint) 'display
 +			   `(image :data ,img-data :type xbm))))
 +
 +    ;; Three overlays.
 +    (insert "  Result 4: ")
 +    (let ((opoint (point)))
 +      (insert "AXD\n\n")
 +      (let ((ov1 (make-overlay opoint (1+ opoint)))
 +	    (ov2 (make-overlay (+ 2 opoint) (+ 3 opoint)))
 +	    (ov3 (make-overlay (1+ opoint) (+ 2 opoint))))
 +	(overlay-put ov1 'after-string "B")
 +	(overlay-put ov2 'before-string "C")
 +	(overlay-put ov3 'display `(image :data ,img-data :type xbm))))))
 +
 +(defun test-redisplay-4 ()
 +  (insert "Test 4: Overlay strings and invisibility:\n\n")
 +  ;; Before and after strings with non-nil `invisibility'.
 +  (insert "  Expected: ABC\n")
 +  (insert "    Result: ")
 +  (let ((opoint (point)))
 +    (insert "ABC\n")
 +    (let ((ov (make-overlay (1+ opoint) (+ 2 opoint))))
 +      (overlay-put ov 'before-string
 +		   (propertize "XX" 'invisible
 +			       'test-redisplay--simple-invis))
 +      (overlay-put ov 'after-string
 +		   (propertize "XX" 'invisible
 +			       'test-redisplay--simple-invis))))
 +
 +  ;; Before and after strings bogus `invisibility' property (value is
 +  ;; not listed in `buffer-invisibility-spec').
 +  (insert "\n  Expected: ABC")
 +  (insert "\n    Result: ")
 +  (let ((opoint (point)))
 +    (insert "B\n")
 +    (let ((ov (make-overlay opoint (1+ opoint))))
 +      (overlay-put ov 'before-string
 +		   (propertize "A" 'invisible 'bogus-invis-spec))
 +      (overlay-put ov 'after-string
 +		   (propertize "C" 'invisible 'bogus-invis-spec))))
 +
 +  ;; Before/after string with ellipsis `invisibility' property.
 +  (insert "\n  Expected: ...B...")
 +  (insert "\n    Result: ")
 +  (let ((opoint (point)))
 +    (insert "B\n")
 +    (let ((ov (make-overlay opoint (1+ opoint))))
 +      (overlay-put ov 'before-string
 +		   (propertize "A" 'invisible 'test-redisplay--ellipsis-invis))
 +      (overlay-put ov 'after-string
 +		   (propertize "C" 'invisible 'test-redisplay--ellipsis-invis))))
 +
 +  ;; Before/after string with partial ellipsis `invisibility' property.
 +  (insert "\n  Expected: A...ABC...C")
 +  (insert "\n    Result: ")
 +  (let ((opoint (point)))
 +    (insert "B\n")
 +    (let ((ov (make-overlay opoint (1+ opoint)))
 +	  (a "AAA")
 +	  (c "CCC"))
 +      (put-text-property 1 2 'invisible 'test-redisplay--ellipsis-invis a)
 +      (put-text-property 1 2 'invisible 'test-redisplay--ellipsis-invis c)
 +      (overlay-put ov 'before-string a)
 +      (overlay-put ov 'after-string  c)))
 +
 +  ;; Display string with `invisibility' property.
 +  (insert "\n  Expected: ABC")
 +  (insert "\n    Result: ")
 +  (let ((opoint (point)))
 +    (insert "AYBC\n")
 +    (let ((ov (make-overlay (1+ opoint) (+ 2 opoint))))
 +      (overlay-put ov 'display
 +		   (propertize "XX" 'invisible
 +			       'test-redisplay--simple-invis))))
 +  ;; Display string with bogus `invisibility' property.
 +  (insert "\n  Expected: ABC")
 +  (insert "\n    Result: ")
 +  (let ((opoint (point)))
 +    (insert "AXC\n")
 +    (let ((ov (make-overlay (1+ opoint) (+ 2 opoint))))
 +      (overlay-put ov 'display
 +		   (propertize "B" 'invisible 'bogus-invis-spec))))
 +  ;; Display string with ellipsis `invisibility' property.
 +  (insert "\n  Expected: A...C")
 +  (insert "\n    Result: ")
 +  (let ((opoint (point)))
 +    (insert "AXC\n")
 +    (let ((ov (make-overlay (1+ opoint) (+ 2 opoint))))
 +      (overlay-put ov 'display
 +		   (propertize "B" 'invisible
 +			       'test-redisplay--ellipsis-invis))))
 +  ;; Display string with partial `invisibility' property.
 +  (insert "\n  Expected: A...C")
 +  (insert "\n    Result: ")
 +  (let ((opoint (point)))
 +    (insert "X\n")
 +    (let ((ov  (make-overlay opoint (1+ opoint)))
 +	  (str "ABC"))
 +      (put-text-property 1 2 'invisible 'test-redisplay--ellipsis-invis str)
 +      (overlay-put ov 'display str)))
 +  ;; Overlay string over invisible text and non-default face.
 +  (insert "\n  Expected: ..." (propertize "ABC" 'face 'highlight) "XYZ")
 +  (insert "\n    Result: ")
 +  (insert (propertize "foo" 'invisible 'test-redisplay--ellipsis-invis))
 +  (let ((ov (make-overlay (point) (point))))
 +    (overlay-put ov 'invisible t)
 +    (overlay-put ov 'window (selected-window))
 +    (overlay-put ov 'after-string
 +                 (propertize "ABC" 'face 'highlight)))
 +  (insert "XYZ\n")
 +  ;; Overlay strings with partial `invisibility' property and with a
 +  ;; display property on the before-string.
 +  (insert "\n  Expected: ..."
 +          (propertize "DEF" 'display '(image :type xpm :file "close.xpm"))
 +          (propertize "ABC" 'face 'highlight) "XYZ")
 +  (insert "\n    Result: ")
 +  (insert (propertize "foo" 'invisible 'test-redisplay--ellipsis-invis))
 +  (let ((ov (make-overlay (point) (point))))
 +    (overlay-put ov 'invisible t)
 +    (overlay-put ov 'window (selected-window))
 +    (overlay-put ov 'after-string
 +                 (propertize "ABC" 'face 'highlight))
 +    (overlay-put ov 'before-string
 +                 (propertize "DEF"
 +                             'display '(image :type xpm :file "close.xpm"))))
 +  (insert "XYZ\n")
 +
 +  ;; Overlay string with 2 adjacent and different invisible
 +  ;; properties.  This caused an infloop before Emacs 25.
 +  (insert "\n  Expected: ABC")
 +  (insert "\n    Result: ")
 +  (let ((opoint (point)))
 +    (insert "ABC\n")
 +    (let ((ov (make-overlay (1+ opoint) (+ 2 opoint)))
 +          (str (concat (propertize "X"
 +                                   'invisible 'test-redisplay--simple-invis)
 +                       (propertize "Y"
 +                                   'invisible 'test-redisplay--simple-invis2))))
 +      (overlay-put ov 'after-string str)))
 +
 +  (insert "\n"))
 +
 +
 +(defun test-redisplay ()
 +  (interactive)
 +  (let ((buf (get-buffer "*Redisplay Test*")))
 +    (if buf
 +	(kill-buffer buf))
 +    (switch-to-buffer (get-buffer-create "*Redisplay Test*"))
 +    (erase-buffer)
 +    (setq buffer-invisibility-spec
 +	  '(test-redisplay--simple-invis
 +            test-redisplay--simple-invis2
 +	    (test-redisplay--ellipsis-invis . t)))
 +    (test-redisplay-1)
 +    (test-redisplay-2)
 +    (test-redisplay-3)
 +    (test-redisplay-4)
 +    (goto-char (point-min))))
 +
diff --cc test/manual/rmailmm.el
index 96acbc4735e,00000000000..fc570fa42b4
mode 100644,000000..100644
--- a/test/manual/rmailmm.el
+++ b/test/manual/rmailmm.el
@@@ -1,93 -1,0 +1,93 @@@
 +;;; rmailmm.el --- tests for mail/rmailmm.el
 +
- ;; Copyright (C) 2006-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2006-2017 Free Software Foundation, Inc.
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 +
 +;;; Commentary:
 +
 +;;; Code:
 +
 +(require 'rmailmm)
 +
 +(defun rmailmm-test-handler ()
 +  "Test of a mail using no MIME parts at all."
 +  (let ((mail "To: alex@gnu.org
 +Content-Type: text/plain; charset=koi8-r
 +Content-Transfer-Encoding: 8bit
 +MIME-Version: 1.0
 +
 +\372\304\322\301\327\323\324\327\325\312\324\305\41"))
 +    (switch-to-buffer (get-buffer-create "*test*"))
 +    (erase-buffer)
 +    (set-buffer-multibyte nil)
 +    (insert mail)
 +    (rmail-mime-show t)
 +    (set-buffer-multibyte t)))
 +
 +(defun rmailmm-test-bulk-handler ()
 +  "Test of a mail used as an example in RFC 2183."
 +  (let ((mail "Content-Type: image/jpeg
 +Content-Disposition: attachment; filename=genome.jpeg;
 +  modification-date=\"Wed, 12 Feb 1997 16:29:51 -0500\";
 +Content-Description: a complete map of the human genome
 +Content-Transfer-Encoding: base64
 +
 +iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAMAAABg3Am1AAAABGdBTUEAALGPC/xhBQAAAAZQ
 +TFRF////AAAAVcLTfgAAAPZJREFUeNq9ldsOwzAIQ+3//+l1WlvA5ZLsoUiTto4TB+ISoAjy
 ++ITfRBfcAmgRFFeAm+J6uhdKdFhFWUgDkFsK0oUp/9G2//Kj7Jx+5tSKOdBscgUYiKHRS/me
 +WATQdRUvAK0Bnmshmtn79PpaLBbbOZkjKvRnjRZoRswOkG1wFchKew2g9wXVJVZL/m4+B+vv
 +9AxQQR2Q33SgAYJzzVACdAWjAfRYzYFO9n6SLnydtQHSMxYDMAKqZ/8FS/lTK+zuq3CtK64L
 +UDwbgUEAUmk2Zyg101d6PhCDySgAvTvDgKiuOrc4dLxUb7UMnhGIexyI+d6U+ABuNAP4Simx
 +lgAAAABJRU5ErkJggg==
 +"))
 +    (switch-to-buffer (get-buffer-create "*test*"))
 +    (erase-buffer)
 +    (insert mail)
 +    (rmail-mime-show)))
 +
 +(defun rmailmm-test-multipart-handler ()
 +  "Test of a mail used as an example in RFC 2046."
 +  (let ((mail "From: Nathaniel Borenstein <nsb@bellcore.com>
 +To: Ned Freed <ned@innosoft.com>
 +Date: Sun, 21 Mar 1993 23:56:48 -0800 (PST)
 +Subject: Sample message
 +MIME-Version: 1.0
 +Content-type: multipart/mixed; boundary=\"simple boundary\"
 +
 +This is the preamble.  It is to be ignored, though it
 +is a handy place for composition agents to include an
 +explanatory note to non-MIME conformant readers.
 +
 +--simple boundary
 +
 +This is implicitly typed plain US-ASCII text.
 +It does NOT end with a linebreak.
 +--simple boundary
 +Content-type: text/plain; charset=us-ascii
 +
 +This is explicitly typed plain US-ASCII text.
 +It DOES end with a linebreak.
 +
 +--simple boundary--
 +
 +This is the epilogue.  It is also to be ignored."))
 +    (switch-to-buffer (get-buffer-create "*test*"))
 +    (erase-buffer)
 +    (insert mail)
 +    (rmail-mime-show t)))
 +
 +;;; rmailmm.el ends here
diff --cc test/src/alloc-tests.el
index 97c6b4f8070,00000000000..af4ad6c6355
mode 100644,000000..100644
--- a/test/src/alloc-tests.el
+++ b/test/src/alloc-tests.el
@@@ -1,33 -1,0 +1,33 @@@
 +;;; alloc-tests.el --- alloc tests -*- lexical-binding: t -*-
 +
- ;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2015-2017 Free Software Foundation, Inc.
 +
 +;; Author: Daniel Colascione <dancol@dancol.org>
 +;; Keywords:
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 +
 +;;; Commentary:
 +
 +;;
 +
 +;;; Code:
 +
 +(require 'ert)
 +(require 'cl-lib)
 +
 +(ert-deftest finalizer-object-type ()
 +  (should (equal (type-of (make-finalizer nil)) 'finalizer)))
diff --cc test/src/buffer-tests.el
index 62875216a31,00000000000..793dddd8bd4
mode 100644,000000..100644
--- a/test/src/buffer-tests.el
+++ b/test/src/buffer-tests.el
@@@ -1,48 -1,0 +1,48 @@@
 +;;; buffer-tests.el --- tests for buffer.c functions -*- lexical-binding: t -*-
 +
- ;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2015-2017 Free Software Foundation, Inc.
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 +
 +;;; Code:
 +
 +(require 'ert)
 +
 +(ert-deftest overlay-modification-hooks-message-other-buf ()
 +  "Test for bug#21824.
 +After a modification-hook has been run and there is an overlay in
 +the *Messages* buffer, the message coalescing [2 times] wrongly
 +runs the modification-hook of the overlay in the 1st buffer, but
 +with parameters from the *Messages* buffer modification."
 +  (let ((buf nil)
 +        (msg-ov nil))
 +    (with-temp-buffer
 +      (insert "123")
 +      (overlay-put (make-overlay 1 3)
 +                   'modification-hooks
 +                   (list (lambda (&rest _)
 +                           (setq buf (current-buffer)))))
 +      (goto-char 2)
 +      (insert "x")
 +      (unwind-protect
 +          (progn
 +            (setq msg-ov (make-overlay 1 1 (get-buffer-create "*Messages*")))
 +            (message "a message")
 +            (message "a message")
 +            (should (eq buf (current-buffer))))
 +        (when msg-ov (delete-overlay msg-ov))))))
 +
 +;;; buffer-tests.el ends here
diff --cc test/src/cmds-tests.el
index 4a30d9872a1,00000000000..207ae75a21d
mode 100644,000000..100644
--- a/test/src/cmds-tests.el
+++ b/test/src/cmds-tests.el
@@@ -1,34 -1,0 +1,34 @@@
 +;;; cmds-tests.el --- Testing some Emacs commands
 +
- ;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
 +
 +;; Author: Nicolas Richard <youngfrog@members.fsf.org>
 +;; Keywords:
 +
 +;; This program is free software; you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; This program is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 +
 +;;; Commentary:
 +
 +;;
 +
 +;;; Code:
 +
 +
 +(ert-deftest self-insert-command-with-negative-argument ()
 +  "Test `self-insert-command' with a negative argument."
 +  (let ((last-command-event ?a))
 +    (should-error (self-insert-command -1))))
 +
 +(provide 'cmds-tests)
 +;;; cmds-tests.el ends here
diff --cc test/src/coding-tests.el
index bd494bc26f8,00000000000..cfcd080281f
mode 100644,000000..100644
--- a/test/src/coding-tests.el
+++ b/test/src/coding-tests.el
@@@ -1,383 -1,0 +1,383 @@@
 +;;; coding-tests.el --- tests for text encoding and decoding
 +
- ;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
 +
 +;; Author: Eli Zaretskii <eliz@gnu.org>
 +;; Author: Kenichi Handa <handa@gnu.org>
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 +
 +;;; Code:
 +
 +(require 'ert)
 +
 +;; Directory to hold test data files.
 +(defvar coding-tests-workdir
 +  (expand-file-name "coding-tests" temporary-file-directory))
 +
 +;; Remove all generated test files.
 +(defun coding-tests-remove-files ()
 +  (delete-directory coding-tests-workdir t))
 +
 +(ert-deftest ert-test-coding-bogus-coding-systems ()
 +  (unwind-protect
 +      (let (test-file)
 +        (or (file-directory-p coding-tests-workdir)
 +            (mkdir coding-tests-workdir t))
 +        (setq test-file (expand-file-name "nonexistent" coding-tests-workdir))
 +        (if (file-exists-p test-file)
 +            (delete-file test-file))
 +        (should-error
 +         (let ((coding-system-for-read 'bogus))
 +           (insert-file-contents test-file)))
 +        ;; See bug #21602.
 +        (setq test-file (expand-file-name "writing" coding-tests-workdir))
 +        (should-error
 +         (let ((coding-system-for-write (intern "\"us-ascii\"")))
 +           (write-region "some text" nil test-file))))
 +    (coding-tests-remove-files)))
 +
 +;; See issue #5251.
 +(ert-deftest ert-test-unibyte-buffer-dos-eol-decode ()
 +  (with-temp-buffer
 +    (set-buffer-multibyte nil)
 +    (insert (encode-coding-string "あ" 'euc-jp) "\xd" "\n")
 +    (decode-coding-region (point-min) (point-max) 'euc-jp-dos)
 +    (should-not (string-match-p "\^M" (buffer-string)))))
 +
 +;; Return the contents (specified by CONTENT-TYPE; ascii, latin, or
 +;; binary) of a test file.
 +(defun coding-tests-file-contents (content-type)
 +  (let* ((ascii "ABCDEFGHIJKLMNOPQRSTUVWXYZ\n")
 +	 (latin (concat ascii "ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏ\n"))
 +	 (binary (string-to-multibyte
 +		  (concat (string-as-unibyte latin)
 +			  (unibyte-string #xC0 #xC1 ?\n)))))
 +    (cond ((eq content-type 'ascii) ascii)
 +	  ((eq content-type 'latin) latin)
 +	  ((eq content-type 'binary) binary)
 +	  (t
 +	   (error "Invalid file content type: %s" content-type)))))
 +
 +;; Generate FILE with CONTENTS encoded by CODING-SYSTEM.
 +;; whose encoding specified by CODING-SYSTEM.
 +(defun coding-tests-gen-file (file contents coding-system)
 +  (or (file-directory-p coding-tests-workdir)
 +      (mkdir coding-tests-workdir t))
 +  (setq file (expand-file-name file coding-tests-workdir))
 +  (with-temp-file file
 +    (set-buffer-file-coding-system coding-system)
 +    (insert contents))
 +  file)
 +
 +;;; The following three functions are filters for contents of a test
 +;;; file.
 +
 +;; Convert all LFs to CR LF sequences in the string STR.
 +(defun coding-tests-lf-to-crlf (str)
 +  (with-temp-buffer
 +    (insert str)
 +    (goto-char (point-min))
 +    (while (search-forward "\n" nil t)
 +      (delete-char -1)
 +      (insert "\r\n"))
 +    (buffer-string)))
 +
 +;; Convert all LFs to CRs in the string STR.
 +(defun coding-tests-lf-to-cr (str)
 +  (with-temp-buffer
 +    (insert str)
 +    (subst-char-in-region (point-min) (point-max) ?\n ?\r)
 +    (buffer-string)))
 +
 +;; Convert all LFs to LF LF sequences in the string STR.
 +(defun coding-tests-lf-to-lflf (str)
 +  (with-temp-buffer
 +    (insert str)
 +    (goto-char (point-min))
 +    (while (search-forward "\n" nil t)
 +      (insert "\n"))
 +    (buffer-string)))
 +
 +;; Prepend the UTF-8 BOM to STR.
 +(defun coding-tests-add-bom (str)
 +  (concat "\xfeff" str))
 +
 +;; Return the name of test file whose contents specified by
 +;; CONTENT-TYPE and whose encoding specified by CODING-SYSTEM.
 +(defun coding-tests-filename (content-type coding-system &optional ext)
 +  (if ext
 +      (expand-file-name (format "%s-%s.%s" content-type coding-system ext)
 +			coding-tests-workdir)
 +    (expand-file-name (format "%s-%s" content-type coding-system)
 +		      coding-tests-workdir)))
 +
 +
 +;;; Check ASCII optimizing decoder
 +
 +;; Generate a test file whose contents specified by CONTENT-TYPE and
 +;; whose encoding specified by CODING-SYSTEM.
 +(defun coding-tests-ao-gen-file (content-type coding-system)
 +  (let ((file (coding-tests-filename content-type coding-system)))
 +    (coding-tests-gen-file file
 +			    (coding-tests-file-contents content-type)
 +			    coding-system)))
 +
 +;; Test the decoding of a file whose contents and encoding are
 +;; specified by CONTENT-TYPE and WRITE-CODING.  The test passes if the
 +;; file is read by READ-CODING and detected as DETECTED-CODING and the
 +;; contents is correctly decoded.
 +;; Optional 5th arg TRANSLATOR is a function to translate the original
 +;; file contents to match with the expected result of decoding.  For
 +;; instance, when a file of dos eol-type is read by unix eol-type,
 +;; `decode-test-lf-to-crlf' must be specified.
 +
 +(defun coding-tests (content-type write-coding read-coding detected-coding
 +				   &optional translator)
 +  (prefer-coding-system 'utf-8-auto)
 +  (let ((filename (coding-tests-filename content-type write-coding)))
 +    (with-temp-buffer
 +      (let ((coding-system-for-read read-coding)
 +	    (contents (coding-tests-file-contents content-type))
 +	    (disable-ascii-optimization nil))
 +	(if translator
 +	    (setq contents (funcall translator contents)))
 +	(insert-file-contents filename)
 +	(if (and (coding-system-equal buffer-file-coding-system detected-coding)
 +		 (string= (buffer-string) contents))
 +	    nil
 +	  (list buffer-file-coding-system
 +		(string-to-list (buffer-string))
 +		(string-to-list contents)))))))
 +
 +(ert-deftest ert-test-coding-ascii ()
 +  (unwind-protect
 +      (progn
 +	(dolist (eol-type '(unix dos mac))
 +	  (coding-tests-ao-gen-file 'ascii eol-type))
 +	(should-not (coding-tests 'ascii 'unix 'undecided 'unix))
 +	(should-not (coding-tests 'ascii 'dos 'undecided 'dos))
 +	(should-not (coding-tests 'ascii 'dos 'dos 'dos))
 +	(should-not (coding-tests 'ascii 'mac 'undecided 'mac))
 +	(should-not (coding-tests 'ascii 'mac 'mac 'mac))
 +	(should-not (coding-tests 'ascii 'dos 'utf-8 'utf-8-dos))
 +	(should-not (coding-tests 'ascii 'dos 'unix 'unix
 +				   'coding-tests-lf-to-crlf))
 +	(should-not (coding-tests 'ascii 'mac 'dos 'dos
 +				   'coding-tests-lf-to-cr))
 +	(should-not (coding-tests 'ascii 'dos 'mac 'mac
 +				   'coding-tests-lf-to-lflf)))
 +    (coding-tests-remove-files)))
 +
 +(ert-deftest ert-test-coding-latin ()
 +  (unwind-protect
 +      (progn
 +	(dolist (coding '("utf-8" "utf-8-with-signature"))
 +	  (dolist (eol-type '("unix" "dos" "mac"))
 +	    (coding-tests-ao-gen-file 'latin
 +				       (intern (concat coding "-" eol-type)))))
 +	(should-not (coding-tests 'latin 'utf-8-unix 'undecided 'utf-8-unix))
 +	(should-not (coding-tests 'latin 'utf-8-unix 'utf-8-unix 'utf-8-unix))
 +	(should-not (coding-tests 'latin 'utf-8-dos 'undecided 'utf-8-dos))
 +	(should-not (coding-tests 'latin 'utf-8-dos 'utf-8-dos 'utf-8-dos))
 +	(should-not (coding-tests 'latin 'utf-8-mac 'undecided 'utf-8-mac))
 +	(should-not (coding-tests 'latin 'utf-8-mac 'utf-8-mac 'utf-8-mac))
 +	(should-not (coding-tests 'latin 'utf-8-dos 'unix 'utf-8-unix
 +				   'coding-tests-lf-to-crlf))
 +	(should-not (coding-tests 'latin 'utf-8-mac 'dos 'utf-8-dos
 +				   'coding-tests-lf-to-cr))
 +	(should-not (coding-tests 'latin 'utf-8-dos 'mac 'utf-8-mac
 +				   'coding-tests-lf-to-lflf))
 +	(should-not (coding-tests 'latin 'utf-8-with-signature-unix 'undecided
 +				   'utf-8-with-signature-unix))
 +	(should-not (coding-tests 'latin 'utf-8-with-signature-unix 'utf-8-auto
 +				   'utf-8-with-signature-unix))
 +	(should-not (coding-tests 'latin 'utf-8-with-signature-dos 'undecided
 +				   'utf-8-with-signature-dos))
 +	(should-not (coding-tests 'latin 'utf-8-with-signature-unix 'utf-8
 +				   'utf-8-unix 'coding-tests-add-bom))
 +	(should-not (coding-tests 'latin 'utf-8-with-signature-unix 'utf-8
 +				   'utf-8-unix 'coding-tests-add-bom)))
 +    (coding-tests-remove-files)))
 +
 +(ert-deftest ert-test-coding-binary ()
 +  (unwind-protect
 +      (progn
 +	(dolist (eol-type '("unix" "dos" "mac"))
 +	  (coding-tests-ao-gen-file 'binary
 +				     (intern (concat "raw-text" "-" eol-type))))
 +	(should-not (coding-tests 'binary 'raw-text-unix 'undecided
 +				   'raw-text-unix))
 +	(should-not (coding-tests 'binary 'raw-text-dos 'undecided
 +				   'raw-text-dos))
 +	(should-not (coding-tests 'binary 'raw-text-mac 'undecided
 +				   'raw-text-mac))
 +	(should-not (coding-tests 'binary 'raw-text-dos 'unix
 +				   'raw-text-unix 'coding-tests-lf-to-crlf))
 +	(should-not (coding-tests 'binary 'raw-text-mac 'dos
 +				   'raw-text-dos 'coding-tests-lf-to-cr))
 +	(should-not (coding-tests 'binary 'raw-text-dos 'mac
 +				   'raw-text-mac 'coding-tests-lf-to-lflf)))
 +    (coding-tests-remove-files)))
 +
 +
 +;;; Check the coding system `prefer-utf-8'.
 +
 +;; Read FILE.  Check if the encoding was detected as DETECT.  If
 +;; PREFER is non-nil, prefer that coding system before reading.
 +
 +(defun coding-tests-prefer-utf-8-read (file detect prefer)
 +  (with-temp-buffer
 +    (with-coding-priority (if prefer (list prefer))
 +      (insert-file-contents file))
 +    (if (eq buffer-file-coding-system detect)
 +	nil
 +      (format "Invalid detection: %s" buffer-file-coding-system))))
 +
 +;; Read FILE, modify it, and write it.  Check if the coding system
 +;; used for writing was CODING.  If CODING-TAG is non-nil, insert
 +;; coding tag with it before writing.  If STR is non-nil, insert it
 +;; before writing.
 +
 +(defun coding-tests-prefer-utf-8-write (file coding-tag coding
 +					      &optional str)
 +  (with-temp-buffer
 +    (insert-file-contents file)
 +    (goto-char (point-min))
 +    (if coding-tag
 +	(insert (format ";; -*- coding: %s; -*-\n" coding-tag))
 +      (insert ";;\n"))
 +    (if str
 +	(insert str))
 +    (write-file (coding-tests-filename 'test 'test "el"))
 +    (if (coding-system-equal buffer-file-coding-system coding)
 +	nil
 +      (format "Incorrect encoding: %s" last-coding-system-used))))
 +
 +(ert-deftest ert-test-coding-prefer-utf-8 ()
 +  (unwind-protect
 +      (let ((ascii (coding-tests-gen-file "ascii.el"
 +					   (coding-tests-file-contents 'ascii)
 +					   'unix))
 +	    (latin (coding-tests-gen-file "utf-8.el"
 +					   (coding-tests-file-contents 'latin)
 +					   'utf-8-unix)))
 +	(should-not (coding-tests-prefer-utf-8-read
 +		     ascii 'prefer-utf-8-unix nil))
 +	(should-not (coding-tests-prefer-utf-8-read
 +		     latin 'utf-8-unix nil))
 +	(should-not (coding-tests-prefer-utf-8-read
 +		     latin 'utf-8-unix 'iso-8859-1))
 +	(should-not (coding-tests-prefer-utf-8-read
 +		     latin 'utf-8-unix 'sjis))
 +	(should-not (coding-tests-prefer-utf-8-write
 +		     ascii nil 'prefer-utf-8-unix))
 +	(should-not (coding-tests-prefer-utf-8-write
 +		     ascii 'iso-8859-1 'iso-8859-1-unix))
 +	(should-not (coding-tests-prefer-utf-8-write
 +		     ascii nil 'utf-8-unix "À")))
 +    (coding-tests-remove-files)))
 +
 +
 +;;; The following is for benchmark testing of the new optimized
 +;;; decoder, not for regression testing.
 +
 +(defun generate-ascii-file ()
 +  (dotimes (i 100000)
 +    (insert-char ?a 80)
 +    (insert "\n")))
 +
 +(defun generate-rarely-nonascii-file ()
 +  (dotimes (i 100000)
 +    (if (/= i 50000)
 +	(insert-char ?a 80)
 +      (insert ?À)
 +      (insert-char ?a 79))
 +    (insert "\n")))
 +
 +(defun generate-mostly-nonascii-file ()
 +  (dotimes (i 30000)
 +    (insert-char ?a 80)
 +    (insert "\n"))
 +  (dotimes (i 20000)
 +    (insert-char ?À 80)
 +    (insert "\n"))
 +  (dotimes (i 10000)
 +    (insert-char ?あ 80)
 +    (insert "\n")))
 +
 +
 +(defvar test-file-list
 +  '((generate-ascii-file
 +     ("~/ascii-tag-utf-8-unix.unix" ";; -*- coding: utf-8-unix; -*-" unix)
 +     ("~/ascii-tag-utf-8.unix" ";; -*- coding: utf-8; -*-" unix)
 +     ("~/ascii-tag-none.unix" "" unix)
 +     ("~/ascii-tag-utf-8-dos.dos" ";; -*- coding: utf-8-dos; -*-" dos)
 +     ("~/ascii-tag-utf-8.dos" ";; -*- coding: utf-8; -*-" dos)
 +     ("~/ascii-tag-none.dos" "" dos))
 +    (generate-rarely-nonascii-file
 +     ("~/utf-8-r-tag-utf-8-unix.unix" ";; -*- coding: utf-8-unix; -*-" utf-8-unix)
 +     ("~/utf-8-r-tag-utf-8.unix" ";; -*- coding: utf-8; -*-" utf-8-unix)
 +     ("~/utf-8-r-tag-none.unix" "" utf-8-unix)
 +     ("~/utf-8-r-tag-utf-8-dos.dos" ";; -*- coding: utf-8-dos; -*-" utf-8-dos)
 +     ("~/utf-8-r-tag-utf-8.dos" ";; -*- coding: utf-8; -*-" utf-8-dos)
 +     ("~/utf-8-r-tag-none.dos" "" utf-8-dos))
 +    (generate-mostly-nonascii-file
 +     ("~/utf-8-m-tag-utf-8-unix.unix" ";; -*- coding: utf-8-unix; -*-" utf-8-unix)
 +     ("~/utf-8-m-tag-utf-8.unix" ";; -*- coding: utf-8; -*-" utf-8-unix)
 +     ("~/utf-8-m-tag-none.unix" "" utf-8-unix)
 +     ("~/utf-8-m-tag-utf-8-dos.dos" ";; -*- coding: utf-8-dos; -*-" utf-8-dos)
 +     ("~/utf-8-m-tag-utf-8.dos" ";; -*- coding: utf-8; -*-" utf-8-dos)
 +     ("~/utf-8-m-tag-none.dos" "" utf-8-dos))))
 +
 +(defun generate-benchmark-test-file ()
 +  (interactive)
 +  (with-temp-buffer
 +    (message "Generating data...")
 +    (dolist (files test-file-list)
 +      (delete-region (point-min) (point-max))
 +      (funcall (car files))
 +      (dolist (file (cdr files))
 +	(message "Writing %s..." (car file))
 +	(goto-char (point-min))
 +	(insert (nth 1 file) "\n")
 +	(let ((coding-system-for-write (nth 2 file)))
 +	  (write-region (point-min) (point-max) (car file)))
 +	(delete-region (point-min) (point))))))
 +
 +(defun benchmark-decoder ()
 +  (let ((gc-cons-threshold 4000000))
 +    (insert "Without optimization:\n")
 +    (dolist (files test-file-list)
 +      (dolist (file (cdr files))
 +	(let* ((disable-ascii-optimization t)
 +	       (result (benchmark-run 10
 +			 (with-temp-buffer (insert-file-contents (car file))))))
 +	  (insert (format "%s: %s\n"  (car file) result)))))
 +    (insert "With optimization:\n")
 +    (dolist (files test-file-list)
 +      (dolist (file (cdr files))
 +	(let* ((disable-ascii-optimization nil)
 +	       (result (benchmark-run 10
 +			 (with-temp-buffer (insert-file-contents (car file))))))
 +	  (insert (format "%s: %s\n" (car file) result)))))))
 +
 +;; Local Variables:
 +;; byte-compile-warnings: (not obsolete)
 +;; End:
 +
 +(provide 'coding-tests)
 +;; coding-tests.el ends here
diff --cc test/src/decompress-tests.el
index f0264ec548d,00000000000..eaec0d01a7b
mode 100644,000000..100644
--- a/test/src/decompress-tests.el
+++ b/test/src/decompress-tests.el
@@@ -1,45 -1,0 +1,45 @@@
 +;;; decompress-tests.el --- Test suite for decompress.
 +
- ;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
 +
 +;; Author: Lars Ingebrigtsen <larsi@gnus.org>
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 +
 +;;; Code:
 +
 +(require 'ert)
 +
 +(defvar zlib-tests-data-directory
 +  (expand-file-name "data/decompress" (getenv "EMACS_TEST_DIRECTORY"))
 +  "Directory containing zlib test data.")
 +
 +(ert-deftest zlib--decompress ()
 +  "Test decompressing a gzipped file."
 +  (when (and (fboundp 'zlib-available-p)
 +	     (zlib-available-p))
 +    (should (string=
 +	     (with-temp-buffer
 +	       (set-buffer-multibyte nil)
 +	       (insert-file-contents-literally
 +		(expand-file-name "foo.gz" zlib-tests-data-directory))
 +	       (zlib-decompress-region (point-min) (point-max))
 +	       (buffer-string))
 +	     "foo\n"))))
 +
 +(provide 'decompress-tests)
 +
 +;;; decompress-tests.el ends here.
diff --cc test/src/fns-tests.el
index c533bad3cdc,00000000000..ee3c5dc77e4
mode 100644,000000..100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@@ -1,247 -1,0 +1,247 @@@
 +;;; fns-tests.el --- tests for src/fns.c
 +
- ;; Copyright (C) 2014-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2014-2017 Free Software Foundation, Inc.
 +
 +;; This file is part of GNU Emacs.
 +
 +;; This program is free software: you can redistribute it and/or
 +;; modify it under the terms of the GNU General Public License as
 +;; published by the Free Software Foundation, either version 3 of the
 +;; License, or (at your option) any later version.
 +;;
 +;; This program is distributed in the hope that it will be useful, but
 +;; WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 +;; General Public License for more details.
 +;;
 +;; You should have received a copy of the GNU General Public License
 +;; along with this program.  If not, see `http://www.gnu.org/licenses/'.
 +
 +;;; Commentary:
 +
 +;;; Code:
 +
 +(require 'cl-lib)
 +(eval-when-compile (require 'cl))
 +
 +(ert-deftest fns-tests-reverse ()
 +  (should-error (reverse))
 +  (should-error (reverse 1))
 +  (should-error (reverse (make-char-table 'foo)))
 +  (should (equal [] (reverse [])))
 +  (should (equal [0] (reverse [0])))
 +  (should (equal [1 2 3 4] (reverse (reverse [1 2 3 4]))))
 +  (should (equal '(a b c d) (reverse (reverse '(a b c d)))))
 +  (should (equal "xyzzy" (reverse (reverse "xyzzy"))))
 +  (should (equal "こんにちは / ｺﾝﾆﾁﾊ" (reverse (reverse "こんにちは / ｺﾝﾆﾁﾊ")))))
 +
 +(ert-deftest fns-tests-nreverse ()
 +  (should-error (nreverse))
 +  (should-error (nreverse 1))
 +  (should-error (nreverse (make-char-table 'foo)))
 +  (should (equal (nreverse "xyzzy") "yzzyx"))
 +  (let ((A []))
 +    (nreverse A)
 +    (should (equal A [])))
 +  (let ((A [0]))
 +    (nreverse A)
 +    (should (equal A [0])))
 +  (let ((A [1 2 3 4]))
 +    (nreverse A)
 +    (should (equal A [4 3 2 1])))
 +  (let ((A [1 2 3 4]))
 +    (nreverse A)
 +    (nreverse A)
 +    (should (equal A [1 2 3 4])))
 +  (let* ((A [1 2 3 4])
 +	 (B (nreverse (nreverse A))))
 +    (should (equal A B))))
 +
 +(ert-deftest fns-tests-reverse-bool-vector ()
 +  (let ((A (make-bool-vector 10 nil)))
 +    (dotimes (i 5) (aset A i t))
 +    (should (equal [nil nil nil nil nil t t t t t] (vconcat (reverse A))))
 +    (should (equal A (reverse (reverse A))))))
 +
 +(ert-deftest fns-tests-nreverse-bool-vector ()
 +  (let ((A (make-bool-vector 10 nil)))
 +    (dotimes (i 5) (aset A i t))
 +    (nreverse A)
 +    (should (equal [nil nil nil nil nil t t t t t] (vconcat A)))
 +    (should (equal [t t t t t nil nil nil nil nil] (vconcat (nreverse A))))))
 +
 +(ert-deftest fns-tests-compare-strings ()
 +  (should-error (compare-strings))
 +  (should-error (compare-strings "xyzzy" "xyzzy"))
 +  (should (= (compare-strings "xyzzy" 0 10 "zyxxy" 0 5) -1))
 +  (should-error (compare-strings "xyzzy" 0 5 "zyxxy" -1 2))
 +  (should-error (compare-strings "xyzzy" 'foo nil "zyxxy" 0 1))
 +  (should-error (compare-strings "xyzzy" 0 'foo "zyxxy" 2 3))
 +  (should-error (compare-strings "xyzzy" 0 2 "zyxxy" 'foo 3))
 +  (should-error (compare-strings "xyzzy" nil 3 "zyxxy" 4 'foo))
 +  (should (eq (compare-strings "" nil nil "" nil nil) t))
 +  (should (eq (compare-strings "" 0 0 "" 0 0) t))
 +  (should (eq (compare-strings "test" nil nil "test" nil nil) t))
 +  (should (eq (compare-strings "test" nil nil "test" nil nil t) t))
 +  (should (eq (compare-strings "test" nil nil "test" nil nil nil) t))
 +  (should (eq (compare-strings "Test" nil nil "test" nil nil t) t))
 +  (should (= (compare-strings "Test" nil nil "test" nil nil) -1))
 +  (should (= (compare-strings "Test" nil nil "test" nil nil) -1))
 +  (should (= (compare-strings "test" nil nil "Test" nil nil) 1))
 +  (should (= (compare-strings "foobaz" nil nil "barbaz" nil nil) 1))
 +  (should (= (compare-strings "barbaz" nil nil "foobar" nil nil) -1))
 +  (should (= (compare-strings "foobaz" nil nil "farbaz" nil nil) 2))
 +  (should (= (compare-strings "farbaz" nil nil "foobar" nil nil) -2))
 +  (should (eq (compare-strings "abcxyz" 0 2 "abcprq" 0 2) t))
 +  (should (eq (compare-strings "abcxyz" 0 -3 "abcprq" 0 -3) t))
 +  (should (= (compare-strings "abcxyz" 0 6 "abcprq" 0 6) 4))
 +  (should (= (compare-strings "abcprq" 0 6 "abcxyz" 0 6) -4))
 +  (should (eq (compare-strings "xyzzy" -3 4 "azza" -3 3) t))
 +  (should (eq (compare-strings "こんにちはｺﾝﾆﾁﾊ" nil nil "こんにちはｺﾝﾆﾁﾊ" nil nil) t))
 +  (should (= (compare-strings "んにちはｺﾝﾆﾁﾊこ" nil nil "こんにちはｺﾝﾆﾁﾊ" nil nil) 1))
 +  (should (= (compare-strings "こんにちはｺﾝﾆﾁﾊ" nil nil "んにちはｺﾝﾆﾁﾊこ" nil nil) -1)))
 +
 +(defun fns-tests--collate-enabled-p ()
 +  "Check whether collation functions are enabled."
 +  (and
 +   ;; When there is no collation library, collation functions fall back
 +   ;; to their lexicographic counterparts.  We don't need to test then.
 +   (not (ignore-errors (string-collate-equalp "" "" t)))
 +   ;; We use a locale, which might not be installed.  Check it.
 +   (ignore-errors
 +     (string-collate-equalp
 +      "" "" (if (eq system-type 'windows-nt) "enu_USA" "en_US.UTF-8")))))
 +
 +(ert-deftest fns-tests-collate-strings ()
 +  (skip-unless (fns-tests--collate-enabled-p))
 +
 +  (should (string-collate-equalp "xyzzy" "xyzzy"))
 +  (should-not (string-collate-equalp "xyzzy" "XYZZY"))
 +
 +  ;; In POSIX or C locales, collation order is lexicographic.
 +  (should (string-collate-lessp "XYZZY" "xyzzy" "POSIX"))
 +  ;; In a language specific locale, collation order is different.
 +  (should (string-collate-lessp
 +	   "xyzzy" "XYZZY"
 +	   (if (eq system-type 'windows-nt) "enu_USA" "en_US.UTF-8")))
 +
 +  ;; Ignore case.
 +  (should (string-collate-equalp "xyzzy" "XYZZY" nil t))
 +
 +  ;; Locale must be valid.
 +  (should-error (string-collate-equalp "xyzzy" "xyzzy" "en_DE.UTF-8")))
 +
 +;; There must be a check for valid codepoints.  (Check not implemented yet)
 +;  (should-error
 +;   (string-collate-equalp (string ?\x00110000) (string ?\x00110000)))
 +;; Invalid UTF-8 sequences shall be indicated.  How to create such strings?
 +
 +(ert-deftest fns-tests-sort ()
 +  (should (equal (sort '(9 5 2 -1 5 3 8 7 4) (lambda (x y) (< x y)))
 +		 '(-1 2 3 4 5 5 7 8 9)))
 +  (should (equal (sort '(9 5 2 -1 5 3 8 7 4) (lambda (x y) (> x y)))
 +		 '(9 8 7 5 5 4 3 2 -1)))
 +  (should (equal (sort '[9 5 2 -1 5 3 8 7 4] (lambda (x y) (< x y)))
 +		 [-1 2 3 4 5 5 7 8 9]))
 +  (should (equal (sort '[9 5 2 -1 5 3 8 7 4] (lambda (x y) (> x y)))
 +		 [9 8 7 5 5 4 3 2 -1]))
 +  (should (equal
 +	   (sort
 +	    (vector
 +	     '(8 . "xxx") '(9 . "aaa") '(8 . "bbb") '(9 . "zzz")
 +	     '(9 . "ppp") '(8 . "ttt") '(8 . "eee") '(9 . "fff"))
 +	    (lambda (x y) (< (car x) (car y))))
 +	   [(8 . "xxx") (8 . "bbb") (8 . "ttt") (8 . "eee")
 +	    (9 . "aaa") (9 . "zzz") (9 . "ppp") (9 . "fff")])))
 +
 +(ert-deftest fns-tests-collate-sort ()
 +  ;; See https://lists.gnu.org/archive/html/emacs-devel/2015-10/msg02505.html.
 +  :expected-result (if (eq system-type 'cygwin) :failed :passed)
 +  (skip-unless (fns-tests--collate-enabled-p))
 +
 +  ;; Punctuation and whitespace characters are relevant for POSIX.
 +  (should
 +   (equal
 +    (sort '("11" "12" "1 1" "1 2" "1.1" "1.2")
 +	  (lambda (a b) (string-collate-lessp a b "POSIX")))
 +    '("1 1" "1 2" "1.1" "1.2" "11" "12")))
 +  ;; Punctuation and whitespace characters are not taken into account
 +  ;; for collation in other locales.
 +  (should
 +   (equal
 +    (sort '("11" "12" "1 1" "1 2" "1.1" "1.2")
 +	  (lambda (a b)
 +	    (let ((w32-collate-ignore-punctuation t))
 +	      (string-collate-lessp
 +	       a b (if (eq system-type 'windows-nt) "enu_USA" "en_US.UTF-8")))))
 +    '("11" "1 1" "1.1" "12" "1 2" "1.2")))
 +
 +  ;; Diacritics are different letters for POSIX, they sort lexicographical.
 +  (should
 +   (equal
 +    (sort '("Ævar" "Agustín" "Adrian" "Eli")
 +	  (lambda (a b) (string-collate-lessp a b "POSIX")))
 +    '("Adrian" "Agustín" "Eli" "Ævar")))
 +  ;; Diacritics are sorted between similar letters for other locales.
 +  (should
 +   (equal
 +    (sort '("Ævar" "Agustín" "Adrian" "Eli")
 +	  (lambda (a b)
 +	    (let ((w32-collate-ignore-punctuation t))
 +	      (string-collate-lessp
 +	       a b (if (eq system-type 'windows-nt) "enu_USA" "en_US.UTF-8")))))
 +    '("Adrian" "Ævar" "Agustín" "Eli"))))
 +
 +(ert-deftest fns-tests-string-version-lessp ()
 +  (should (string-version-lessp "foo2.png" "foo12.png"))
 +  (should (not (string-version-lessp "foo12.png" "foo2.png")))
 +  (should (string-version-lessp "foo12.png" "foo20000.png"))
 +  (should (not (string-version-lessp "foo20000.png" "foo12.png")))
 +  (should (string-version-lessp "foo.png" "foo2.png"))
 +  (should (not (string-version-lessp "foo2.png" "foo.png")))
 +  (should (equal (sort '("foo12.png" "foo2.png" "foo1.png")
 +                       'string-version-lessp)
 +                 '("foo1.png" "foo2.png" "foo12.png")))
 +  (should (string-version-lessp "foo2" "foo1234"))
 +  (should (not (string-version-lessp "foo1234" "foo2")))
 +  (should (string-version-lessp "foo.png" "foo2"))
 +  (should (string-version-lessp "foo1.25.5.png" "foo1.125.5"))
 +  (should (string-version-lessp "2" "1245"))
 +  (should (not (string-version-lessp "1245" "2"))))
 +
 +(ert-deftest fns-tests-func-arity ()
 +  (should (equal (func-arity 'car) '(1 . 1)))
 +  (should (equal (func-arity 'caar) '(1 . 1)))
 +  (should (equal (func-arity 'format) '(1 . many)))
 +  (require 'info)
 +  (should (equal (func-arity 'Info-goto-node) '(1 . 3)))
 +  (should (equal (func-arity (lambda (&rest x))) '(0 . many)))
 +  (should (equal (func-arity (eval (lambda (x &optional y)) nil)) '(1 . 2)))
 +  (should (equal (func-arity (eval (lambda (x &optional y)) t)) '(1 . 2)))
 +  (should (equal (func-arity 'let) '(1 . unevalled))))
 +
 +(ert-deftest fns-tests-hash-buffer ()
 +  (should (equal (sha1 "foo") "0beec7b5ea3f0fdbc95d0dd47f3c5bc275da8a33"))
 +  (should (equal (with-temp-buffer
 +                   (insert "foo")
 +                   (buffer-hash))
 +                 (sha1 "foo")))
 +  ;; This tests whether the presence of a gap in the middle of the
 +  ;; buffer is handled correctly.
 +  (should (equal (with-temp-buffer
 +                   (insert "foo")
 +                   (goto-char 2)
 +                   (insert " ")
 +                   (backward-delete-char 1)
 +                   (buffer-hash))
 +                 (sha1 "foo"))))
 +
 +(ert-deftest fns-tests-mapcan ()
 +  (should-error (mapcan))
 +  (should-error (mapcan #'identity))
 +  (should-error (mapcan #'identity (make-char-table 'foo)))
 +  (should (equal (mapcan #'list '(1 2 3)) '(1 2 3)))
 +  ;; `mapcan' is destructive
 +  (let ((data '((foo) (bar))))
 +    (should (equal (mapcan #'identity data) '(foo bar)))
 +    (should (equal data                     '((foo bar) (bar))))))
diff --cc test/src/font-tests.el
index f0f0d31efc7,00000000000..dc48577025c
mode 100644,000000..100644
--- a/test/src/font-tests.el
+++ b/test/src/font-tests.el
@@@ -1,167 -1,0 +1,167 @@@
 +;;; font-tests.el --- Test suite for font-related functions.
 +
- ;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2011-2017 Free Software Foundation, Inc.
 +
 +;; Author: Chong Yidong <cyd@stupidchicken.com>
 +;; Keywords:       internal
 +;; Human-Keywords: internal
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 +
 +;;; Commentary:
 +
 +;; Type M-x test-font-parse RET to generate the test buffer.
 +
 +;;; Code:
 +
 +(require 'ert)
 +
 +(defvar font-parse-tests--data
 +  `((" " ,(intern " ") nil nil nil nil)
 +    ("Monospace" Monospace nil nil nil nil)
 +    ("Monospace Serif" ,(intern "Monospace Serif") nil nil nil nil)
 +    ("Foo1" Foo1 nil nil nil nil)
 +    ("12" nil 12.0 nil nil nil)
 +    ("12 " ,(intern "12 ") nil nil nil nil)
 +    ;; Fontconfig format
 +    ("Foo:" Foo nil nil nil nil)
 +    ("Foo-8" Foo 8.0 nil nil nil)
 +    ("Foo-18:" Foo 18.0 nil nil nil)
 +    ("Foo-18:light" Foo 18.0 light nil nil)
 +    ("Foo 10:weight=bold" ,(intern "Foo 10") nil bold nil nil)
 +    ("Foo-12:weight=bold" Foo 12.0 bold nil nil)
 +    ("Foo 8-20:slant=oblique" ,(intern "Foo 8") 20.0 nil oblique nil)
 +    ("Foo:light:roman" Foo nil light roman nil)
 +    ("Foo:italic:roman" Foo nil nil roman nil)
 +    ("Foo 12:light:oblique" ,(intern "Foo 12") nil light oblique nil)
 +    ("Foo-12:demibold:oblique" Foo 12.0 demibold oblique nil)
 +    ("Foo:black:proportional" Foo nil black nil 0)
 +    ("Foo-10:black:proportional" Foo 10.0 black nil 0)
 +    ("Foo:weight=normal" Foo nil normal nil nil)
 +    ("Foo:weight=bold" Foo nil bold nil nil)
 +    ("Foo:weight=bold:slant=italic" Foo nil bold italic)
 +    ("Foo:weight=bold:slant=italic:mono" Foo nil bold italic 100)
 +    ("Foo-10:demibold:slant=normal" Foo 10.0 demibold normal nil)
 +    ("Foo 11-16:oblique:weight=bold" ,(intern "Foo 11") 16.0 bold oblique nil)
 +    ("Foo:oblique:randomprop=randomtag:weight=bold" Foo nil bold oblique nil)
 +    ("Foo:randomprop=randomtag:bar=baz" Foo nil nil nil nil)
 +    ("Foo Book Light:bar=baz" ,(intern "Foo Book Light") nil nil nil nil)
 +    ("Foo Book Light 10:bar=baz" ,(intern "Foo Book Light 10") nil nil nil nil)
 +    ("Foo Book Light-10:bar=baz" ,(intern "Foo Book Light") 10.0 nil nil nil)
 +    ;; GTK format
 +    ("Oblique" nil nil nil oblique nil)
 +    ("Bold 17" nil 17.0 bold nil nil)
 +    ("17 Bold" ,(intern "17") nil bold nil nil)
 +    ("Book Oblique 2" nil 2.0 book oblique nil)
 +    ("Bar 7" Bar 7.0 nil nil nil)
 +    ("Bar Ultra-Light" Bar nil ultra-light nil nil)
 +    ("Bar Light 8" Bar 8.0 light nil nil)
 +    ("Bar Book Medium 9" Bar 9.0 medium nil nil)
 +    ("Bar Semi-Bold Italic 10" Bar 10.0 semi-bold italic nil)
 +    ("Bar Semi-Condensed Bold Italic 11" Bar 11.0 bold italic nil)
 +    ("Foo 10 11" ,(intern "Foo 10") 11.0 nil nil nil)
 +    ("Foo 1985 Book" ,(intern "Foo 1985") nil book nil nil)
 +    ("Foo 1985 A Book" ,(intern "Foo 1985 A") nil book nil nil)
 +    ("Foo 1 Book 12" ,(intern "Foo 1") 12.0 book nil nil)
 +    ("Foo A Book 12 A" ,(intern "Foo A Book 12 A") nil nil nil nil)
 +    ("Foo 1985 Book 12 Oblique" ,(intern "Foo 1985 Book 12") nil nil oblique nil)
 +    ("Foo 1985 Book 12 Italic 10" ,(intern "Foo 1985 Book 12") 10.0 nil italic nil)
 +    ("Foo Book Bar 6 Italic" ,(intern "Foo Book Bar 6") nil nil italic nil)
 +    ("Foo Book Bar Bold" ,(intern "Foo Book Bar") nil bold nil nil))
 +  "List of font names parse data.
 +Each element should have the form
 +   (NAME FAMILY SIZE WEIGHT SLANT SPACING)
 +where NAME is the name to parse, and the remainder are the
 +expected font properties from parsing NAME.")
 +
 +(defun font-parse-check (name prop expected)
 +  (let ((result (font-get (font-spec :name name) prop)))
 +    (if (and (symbolp result) (symbolp expected))
 +	(eq result expected)
 +      (equal result expected))))
 +
 +(put 'font-parse-check 'ert-explainer 'font-parse-explain)
 +
 +(defun font-parse-explain (name prop expected)
 +  (let ((result (font-get (font-spec :name name) prop))
 +	(propname (symbol-name prop)))
 +    (format "Parsing `%s': expected %s `%s', got `%s'."
 +	    name (substring propname 1) expected
 +	    (font-get (font-spec :name name) prop))))
 +
 +(ert-deftest font-parse-tests ()
 +  "Test parsing of Fontconfig-style and GTK-style font names."
 +  (dolist (test font-parse-tests--data)
 +    (let* ((name (nth 0 test)))
 +      (should (font-parse-check name :family (nth 1 test)))
 +      (should (font-parse-check name :size   (nth 2 test)))
 +      (should (font-parse-check name :weight (nth 3 test)))
 +      (should (font-parse-check name :slant  (nth 4 test)))
 +      (should (font-parse-check name :spacing (nth 5 test))))))
 +
 +
 +(defun test-font-parse ()
 +  "Test font name parsing."
 +  (interactive)
 +  (switch-to-buffer (generate-new-buffer "*Font Pase Test*"))
 +  (setq show-trailing-whitespace nil)
 +  (let ((pass-face '((t :foreground "green")))
 +	(fail-face '((t :foreground "red"))))
 +    (dolist (test font-parse-tests--data)
 +      (let* ((name (nth 0 test))
 +	     (fs (font-spec :name name))
 +	     (family  (font-get fs :family))
 +	     (size    (font-get fs :size))
 +	     (weight  (font-get fs :weight))
 +	     (slant   (font-get fs :slant))
 +	     (spacing (font-get fs :spacing)))
 +	(insert name)
 +	(if (> (current-column) 20)
 +	    (insert "\n"))
 +	(indent-to-column 21)
 +	(insert (propertize (symbol-name family)
 +			    'face (if (eq family (nth 1 test))
 +				      pass-face
 +				    fail-face)))
 +	(indent-to-column 40)
 +	(insert (propertize (format "%s" size)
 +			    'face (if (equal size (nth 2 test))
 +				      pass-face
 +				    fail-face)))
 +	(indent-to-column 48)
 +	(insert (propertize (format "%s" weight)
 +			    'face (if (eq weight (nth 3 test))
 +				      pass-face
 +				    fail-face)))
 +	(indent-to-column 60)
 +	(insert (propertize (format "%s" slant)
 +			    'face (if (eq slant (nth 4 test))
 +				      pass-face
 +				    fail-face)))
 +	(indent-to-column 69)
 +	(insert (propertize (format "%s" spacing)
 +			    'face (if (eq spacing (nth 5 test))
 +				      pass-face
 +				    fail-face)))
 +	(insert "\n"))))
 +  (goto-char (point-min)))
 +
 +;; Local Variables:
 +;; no-byte-compile: t
 +;; End:
 +
 +(provide 'font-tests)
 +;;; font-tests.el ends here.
diff --cc test/src/inotify-tests.el
index 54977925f86,00000000000..f30aecc9c4f
mode 100644,000000..100644
--- a/test/src/inotify-tests.el
+++ b/test/src/inotify-tests.el
@@@ -1,64 -1,0 +1,64 @@@
 +;;; inotify-tests.el --- Test suite for inotify. -*- lexical-binding: t -*-
 +
- ;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2012-2017 Free Software Foundation, Inc.
 +
 +;; Author: Rüdiger Sonderfeld <ruediger@c-plusplus.de>
 +;; Keywords:       internal
 +;; Human-Keywords: internal
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 +
 +;;; Code:
 +
 +(require 'ert)
 +
 +(declare-function inotify-add-watch "inotify.c" (file-name aspect callback))
 +(declare-function inotify-rm-watch "inotify.c" (watch-descriptor))
 +
 +;; (ert-deftest filewatch-file-watch-aspects-check ()
 +;;   "Test whether `file-watch' properly checks the aspects."
 +;;   (let ((temp-file (make-temp-file "filewatch-aspects")))
 +;;     (should (stringp temp-file))
 +;;     (should-error (file-watch temp-file 'wrong nil)
 +;;                   :type 'error)
 +;;     (should-error (file-watch temp-file '(modify t) nil)
 +;;                   :type 'error)
 +;;     (should-error (file-watch temp-file '(modify all-modify) nil)
 +;;                   :type 'error)
 +;;     (should-error (file-watch temp-file '(access wrong modify) nil)
 +;;                   :type 'error)))
 +
 +(ert-deftest inotify-file-watch-simple ()
 +  "Test if watching a normal file works."
 +
 +  (skip-unless (featurep 'inotify))
 +  (let ((temp-file (make-temp-file "inotify-simple"))
 +	(events 0))
 +    (let ((wd
 +	   (inotify-add-watch temp-file t (lambda (_ev)
 +					    (setq events (1+ events))))))
 +      (unwind-protect
 +	  (progn
 +	    (with-temp-file temp-file
 +	      (insert "Foo\n"))
 +	    (read-event nil nil 5)
 +	    (should (> events 0)))
 +	(inotify-rm-watch wd)
 +	(delete-file temp-file)))))
 +
 +(provide 'inotify-tests)
 +
 +;;; inotify-tests.el ends here.
diff --cc test/src/keymap-tests.el
index 26d34858703,00000000000..c5b9d0cc71c
mode 100644,000000..100644
--- a/test/src/keymap-tests.el
+++ b/test/src/keymap-tests.el
@@@ -1,50 -1,0 +1,50 @@@
 +;;; keymap-tests.el --- Test suite for src/keymap.c
 +
- ;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2015-2017 Free Software Foundation, Inc.
 +
 +;; Author: Juanma Barranquero <lekktu@gmail.com>
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 +
 +;;; Code:
 +
 +(require 'ert)
 +
 +(ert-deftest keymap-store_in_keymap-XFASTINT-on-non-characters ()
 +  "Check for bug fixed in \"Fix assertion violation in define-key\",
 +commit 86c19714b097aa477d339ed99ffb5136c755a046."
 +  (let ((def (lookup-key Buffer-menu-mode-map [32])))
 +    (unwind-protect
 +        (progn
 +          (should-not (eq def 'undefined))
 +          ;; This will cause an assertion violation if the bug is present.
 +          ;; We could run an inferior Emacs process and check for the return
 +          ;; status, but in some environments an assertion failure triggers
 +          ;; an abort dialog that requires user intervention anyway.
 +          (define-key Buffer-menu-mode-map [(32 . 32)] 'undefined)
 +          (should (eq (lookup-key Buffer-menu-mode-map [32]) 'undefined)))
 +      (define-key Buffer-menu-mode-map [32] def))))
 +
 +(ert-deftest keymap-where-is-internal-test ()
 +  "Make sure we don't crash when `where-is-preferred-modifier' is not a symbol."
 +  (should
 +   (equal (let ((where-is-preferred-modifier "alt"))
 +            (where-is-internal 'execute-extended-command global-map t))
 +          [#x8000078])))
 +
 +(provide 'keymap-tests)
 +
 +;;; keymap-tests.el ends here
diff --cc test/src/print-tests.el
index 1abfa53581c,00000000000..b3ffc23e120
mode 100644,000000..100644
--- a/test/src/print-tests.el
+++ b/test/src/print-tests.el
@@@ -1,62 -1,0 +1,62 @@@
 +;;; print-tests.el --- tests for src/print.c         -*- lexical-binding: t; -*-
 +
- ;; Copyright (C) 2014-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2014-2017 Free Software Foundation, Inc.
 +
 +;; This file is part of GNU Emacs.
 +
 +;; This program is free software; you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; This program is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 +
 +;;; Code:
 +
 +(require 'ert)
 +
 +(ert-deftest print-hex-backslash ()
 +  (should (string= (let ((print-escape-multibyte t)
 +                         (print-escape-newlines t))
 +                     (prin1-to-string "\u00A2\ff"))
 +                   "\"\\x00a2\\ff\"")))
 +
 +(ert-deftest terpri ()
 +  (should (string= (with-output-to-string
 +                     (princ 'abc)
 +                     (should (terpri nil t)))
 +                   "abc\n"))
 +  (should (string= (with-output-to-string
 +                     (should-not (terpri nil t))
 +                     (princ 'xyz))
 +                   "xyz"))
 +  (message nil)
 +  (if noninteractive
 +      (progn (should            (terpri nil t))
 +             (should-not        (terpri nil t))
 +             (princ 'abc)
 +             (should            (terpri nil t))
 +             (should-not        (terpri nil t)))
 +    (should (string= (progn (should-not (terpri nil t))
 +                            (princ 'abc)
 +                            (should (terpri nil t))
 +                            (current-message))
 +                     "abc\n")))
 +  (let ((standard-output
 +         (with-current-buffer (get-buffer-create "*terpri-test*")
 +           (insert "--------")
 +           (point-max-marker))))
 +    (should     (terpri nil t))
 +    (should-not (terpri nil t))
 +    (should (string= (with-current-buffer (marker-buffer standard-output)
 +                       (buffer-string))
 +                     "--------\n"))))
 +
 +(provide 'print-tests)
 +;;; print-tests.el ends here
diff --cc test/src/process-tests.el
index 8cc59bf9feb,00000000000..04dc903f3a9
mode 100644,000000..100644
--- a/test/src/process-tests.el
+++ b/test/src/process-tests.el
@@@ -1,166 -1,0 +1,166 @@@
 +;;; process-tests.el --- Testing the process facilities
 +
- ;; Copyright (C) 2013-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
 +
 +;; This program is free software; you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; This program is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 +
 +;;; Commentary:
 +
 +;;
 +
 +;;; Code:
 +
 +(require 'ert)
 +
 +;; Timeout in seconds; the test fails if the timeout is reached.
 +(defvar process-test-sentinel-wait-timeout 2.0)
 +
 +;; Start a process that exits immediately.  Call WAIT-FUNCTION,
 +;; possibly multiple times, to wait for the process to complete.
 +(defun process-test-sentinel-wait-function-working-p (wait-function)
 +  (let ((proc (start-process "test" nil "bash" "-c" "exit 20"))
 +	(sentinel-called nil)
 +	(start-time (float-time)))
 +    (set-process-sentinel proc (lambda (proc msg)
 +				 (setq sentinel-called t)))
 +    (while (not (or sentinel-called
 +		    (> (- (float-time) start-time)
 +		       process-test-sentinel-wait-timeout)))
 +      (funcall wait-function))
 +    (cl-assert (eq (process-status proc) 'exit))
 +    (cl-assert (= (process-exit-status proc) 20))
 +    sentinel-called))
 +
 +(ert-deftest process-test-sentinel-accept-process-output ()
 +  (skip-unless (executable-find "bash"))
 +  (should (process-test-sentinel-wait-function-working-p
 +           #'accept-process-output)))
 +
 +(ert-deftest process-test-sentinel-sit-for ()
 +  (skip-unless (executable-find "bash"))
 +  (should
 +   (process-test-sentinel-wait-function-working-p (lambda () (sit-for 0.01 t)))))
 +
 +(when (eq system-type 'windows-nt)
 +  (ert-deftest process-test-quoted-batfile ()
 +    "Check that Emacs hides CreateProcess deficiency (bug#18745)."
 +    (let (batfile)
 +      (unwind-protect
 +          (progn
 +            ;; CreateProcess will fail when both the bat file and 1st
 +            ;; argument are quoted, so include spaces in both of those
 +            ;; to force quoting.
 +            (setq batfile (make-temp-file "echo args" nil ".bat"))
 +            (with-temp-file batfile
 +              (insert "@echo arg1=%1, arg2=%2\n"))
 +            (with-temp-buffer
 +              (call-process batfile nil '(t t) t "x &y")
 +              (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n")))
 +            (with-temp-buffer
 +              (call-process-shell-command
 +               (mapconcat #'shell-quote-argument (list batfile "x &y") " ")
 +               nil '(t t) t)
 +              (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n"))))
 +        (when batfile (delete-file batfile))))))
 +
 +(ert-deftest process-test-stderr-buffer ()
 +  (skip-unless (executable-find "bash"))
 +  (let* ((stdout-buffer (generate-new-buffer "*stdout*"))
 +	 (stderr-buffer (generate-new-buffer "*stderr*"))
 +	 (proc (make-process :name "test"
 +			     :command (list "bash" "-c"
 +					    (concat "echo hello stdout!; "
 +						    "echo hello stderr! >&2; "
 +						    "exit 20"))
 +			     :buffer stdout-buffer
 +			     :stderr stderr-buffer))
 +	 (sentinel-called nil)
 +	 (start-time (float-time)))
 +    (set-process-sentinel proc (lambda (proc msg)
 +				 (setq sentinel-called t)))
 +    (while (not (or sentinel-called
 +		    (> (- (float-time) start-time)
 +		       process-test-sentinel-wait-timeout)))
 +      (accept-process-output))
 +    (cl-assert (eq (process-status proc) 'exit))
 +    (cl-assert (= (process-exit-status proc) 20))
 +    (should (with-current-buffer stdout-buffer
 +	      (goto-char (point-min))
 +	      (looking-at "hello stdout!")))
 +    (should (with-current-buffer stderr-buffer
 +	      (goto-char (point-min))
 +	      (looking-at "hello stderr!")))))
 +
 +(ert-deftest process-test-stderr-filter ()
 +  (skip-unless (executable-find "bash"))
 +  (let* ((sentinel-called nil)
 +	 (stderr-sentinel-called nil)
 +	 (stdout-output nil)
 +	 (stderr-output nil)
 +	 (stdout-buffer (generate-new-buffer "*stdout*"))
 +	 (stderr-buffer (generate-new-buffer "*stderr*"))
 +	 (stderr-proc (make-pipe-process :name "stderr"
 +					 :buffer stderr-buffer))
 +	 (proc (make-process :name "test" :buffer stdout-buffer
 +			     :command (list "bash" "-c"
 +					    (concat "echo hello stdout!; "
 +						    "echo hello stderr! >&2; "
 +						    "exit 20"))
 +			     :stderr stderr-proc))
 +	 (start-time (float-time)))
 +    (set-process-filter proc (lambda (proc input)
 +			       (push input stdout-output)))
 +    (set-process-sentinel proc (lambda (proc msg)
 +				 (setq sentinel-called t)))
 +    (set-process-filter stderr-proc (lambda (proc input)
 +				      (push input stderr-output)))
 +    (set-process-sentinel stderr-proc (lambda (proc input)
 +					(setq stderr-sentinel-called t)))
 +    (while (not (or sentinel-called
 +		    (> (- (float-time) start-time)
 +		       process-test-sentinel-wait-timeout)))
 +      (accept-process-output))
 +    (cl-assert (eq (process-status proc) 'exit))
 +    (cl-assert (= (process-exit-status proc) 20))
 +    (should sentinel-called)
 +    (should (equal 1 (with-current-buffer stdout-buffer
 +		       (point-max))))
 +    (should (equal "hello stdout!\n"
 +		   (mapconcat #'identity (nreverse stdout-output) "")))
 +    (should stderr-sentinel-called)
 +    (should (equal 1 (with-current-buffer stderr-buffer
 +		       (point-max))))
 +    (should (equal "hello stderr!\n"
 +		   (mapconcat #'identity (nreverse stderr-output) "")))))
 +
 +(ert-deftest start-process-should-not-modify-arguments ()
 +  "`start-process' must not modify its arguments in-place."
 +  ;; See bug#21831.
 +  (let* ((path (pcase system-type
 +                 ((or 'windows-nt 'ms-dos)
 +                  ;; Make sure the file name uses forward slashes.
 +                  ;; The original bug was that 'start-process' would
 +                  ;; convert forward slashes to backslashes.
 +                  (expand-file-name (executable-find "attrib.exe")))
 +                 (_ "/bin//sh")))
 +         (samepath (copy-sequence path)))
 +    ;; Make sure 'start-process' actually goes all the way and invokes
 +    ;; the program.
 +    (should (process-live-p (condition-case nil
 +                                (start-process "" nil path)
 +                              (error nil))))
 +    (should (equal path samepath))))
 +
 +(provide 'process-tests)
 +;; process-tests.el ends here.
diff --cc test/src/textprop-tests.el
index ceb48d1b2db,00000000000..d4c8925b5db
mode 100644,000000..100644
--- a/test/src/textprop-tests.el
+++ b/test/src/textprop-tests.el
@@@ -1,72 -1,0 +1,72 @@@
 +;;; textprop-tests.el --- Test suite for text properties.
 +
- ;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2015-2017 Free Software Foundation, Inc.
 +
 +;; Author: Wolfgang Jenkner <wjenkner@inode.at>
 +;; Keywords: internal
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 +
 +;;; Code:
 +
 +(require 'ert)
 +
 +(ert-deftest textprop-tests-format ()
 +  "Test `format' with text properties."
 +  ;; See Bug#21351.
 +  (should (equal-including-properties
 +           (format #("mouse-1, RET: %s -- w: copy %s"
 +                     12 20 (face minibuffer-prompt)
 +                     21 30 (face minibuffer-prompt))
 +                   "visit" "link")
 +           #("mouse-1, RET: visit -- w: copy link"
 +             12 23 (face minibuffer-prompt)
 +             24 35 (face minibuffer-prompt)))))
 +
 +(ert-deftest textprop-tests-font-lock--remove-face-from-text-property ()
 +  "Test `font-lock--remove-face-from-text-property'."
 +  (let* ((string "foobar")
 +	 (stack (list string))
 +	 (faces '(bold (:foreground "red") underline)))
 +    ;; Build each string in `stack' by adding a face to the previous
 +    ;; string.
 +    (let ((faces (reverse faces)))
 +      (push (copy-sequence (car stack)) stack)
 +      (put-text-property 0 3 'font-lock-face (pop faces) (car stack))
 +      (push (copy-sequence (car stack)) stack)
 +      (put-text-property 3 6 'font-lock-face (pop faces) (car stack))
 +      (push (copy-sequence (car stack)) stack)
 +      (font-lock-prepend-text-property 2 5
 +				       'font-lock-face (pop faces) (car stack)))
 +    ;; Check that removing the corresponding face from each string
 +    ;; yields the previous string in `stack'.
 +    (while faces
 +      ;; (message "%S" (car stack))
 +      (should (equal-including-properties
 +	       (progn
 +		 (font-lock--remove-face-from-text-property 0 6
 +							    'font-lock-face
 +							    (pop faces)
 +							    (car stack))
 +		 (pop stack))
 +	       (car stack))))
 +    ;; Sanity check.
 +    ;; (message "%S" (car stack))
 +    (should (and (equal-including-properties (pop stack) string)
 +		 (null stack)))))
 +
 +(provide 'textprop-tests)
 +;; textprop-tests.el ends here.
diff --cc test/src/undo-tests.el
index b1c786993e8,00000000000..fbd3bf84a42
mode 100644,000000..100644
--- a/test/src/undo-tests.el
+++ b/test/src/undo-tests.el
@@@ -1,448 -1,0 +1,448 @@@
 +;;; undo-tests.el --- Tests of primitive-undo
 +
- ;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2012-2017 Free Software Foundation, Inc.
 +
 +;; Author: Aaron S. Hawley <aaron.s.hawley@gmail.com>
 +
 +;; This program is free software: you can redistribute it and/or
 +;; modify it under the terms of the GNU General Public License as
 +;; published by the Free Software Foundation, either version 3 of the
 +;; License, or (at your option) any later version.
 +;;
 +;; This program is distributed in the hope that it will be useful, but
 +;; WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 +;; General Public License for more details.
 +;;
 +;; You should have received a copy of the GNU General Public License
 +;; along with this program.  If not, see `http://www.gnu.org/licenses/'.
 +
 +;;; Commentary:
 +
 +;; Profiling when the code was translate from C to Lisp on 2012-12-24.
 +
 +;;; C
 +
 +;; (elp-instrument-function 'primitive-undo)
 +;; (load-file "undo-test.elc")
 +;; (benchmark 100 '(let ((undo-test5-error nil)) (undo-test-all)))
 +;; Elapsed time: 305.218000s (104.841000s in 14804 GCs)
 +;; M-x elp-results
 +;; Function Name   Call Count  Elapsed Time  Average Time
 +;; primitive-undo  2600        3.4889999999  0.0013419230
 +
 +;;; Lisp
 +
 +;; (load-file "primundo.elc")
 +;; (elp-instrument-function 'primitive-undo)
 +;; (benchmark 100 '(undo-test-all))
 +;; Elapsed time: 295.974000s (104.582000s in 14704 GCs)
 +;; M-x elp-results
 +;; Function Name   Call Count  Elapsed Time  Average Time
 +;; primitive-undo  2700        3.6869999999  0.0013655555
 +
 +;;; Code:
 +
 +(require 'ert)
 +
 +(ert-deftest undo-test0 ()
 +  "Test basics of \\[undo]."
 +  (with-temp-buffer
 +    (buffer-enable-undo)
 +    (condition-case err
 +      (undo)
 +      (error
 +       (unless (string= "No further undo information"
 +                        (cadr err))
 +         (error err))))
 +    (undo-boundary)
 +    (insert "This")
 +    (undo-boundary)
 +    (erase-buffer)
 +    (undo-boundary)
 +    (insert "That")
 +    (undo-boundary)
 +    (forward-word -1)
 +    (undo-boundary)
 +    (insert "With ")
 +    (undo-boundary)
 +    (forward-word -1)
 +    (undo-boundary)
 +    (kill-word 1)
 +    (undo-boundary)
 +    (put-text-property (point-min) (point-max) 'face 'bold)
 +    (undo-boundary)
 +    (remove-text-properties (point-min) (point-max) '(face default))
 +    (undo-boundary)
 +    (set-buffer-multibyte (not enable-multibyte-characters))
 +    (undo-boundary)
 +    (undo)
 +    (should
 +     (equal (should-error (undo-more nil))
 +            '(wrong-type-argument number-or-marker-p nil)))
 +    (undo-more 7)
 +    (should (string-equal "" (buffer-string)))))
 +
 +(ert-deftest undo-test1 ()
 +  "Test undo of \\[undo] command (redo)."
 +  (with-temp-buffer
 +    (buffer-enable-undo)
 +    (undo-boundary)
 +    (insert "This")
 +    (undo-boundary)
 +    (erase-buffer)
 +    (undo-boundary)
 +    (insert "That")
 +    (undo-boundary)
 +    (forward-word -1)
 +    (undo-boundary)
 +    (insert "With ")
 +    (undo-boundary)
 +    (forward-word -1)
 +    (undo-boundary)
 +    (kill-word 1)
 +    (undo-boundary)
 +    (facemenu-add-face 'bold (point-min) (point-max))
 +    (undo-boundary)
 +    (set-buffer-multibyte (not enable-multibyte-characters))
 +    (undo-boundary)
 +    (should
 +     (string-equal (buffer-string)
 +                   (progn
 +                     (undo)
 +                     (undo-more 4)
 +                     (undo)
 +                     ;(undo-more -4)
 +                     (buffer-string))))))
 +
 +(ert-deftest undo-test2 ()
 +  "Test basic redoing with \\[undo] command."
 +  (with-temp-buffer
 +    (buffer-enable-undo)
 +    (undo-boundary)
 +    (insert "One")
 +    (undo-boundary)
 +    (insert " Zero")
 +    (undo-boundary)
 +    (push-mark nil t)
 +    (delete-region (save-excursion
 +                     (forward-word -1)
 +                     (point)) (point))
 +    (undo-boundary)
 +    (beginning-of-line)
 +    (insert "Zero")
 +    (undo-boundary)
 +    (undo)
 +    (should
 +     (string-equal (buffer-string)
 +                   (progn
 +                     (undo-more 2)
 +                     (undo)
 +                     (buffer-string))))))
 +
 +(ert-deftest undo-test4 ()
 +  "Test \\[undo] of \\[flush-lines]."
 +  (with-temp-buffer
 +    (buffer-enable-undo)
 +    (dotimes (i 1048576)
 +      (if (zerop (% i 2))
 +          (insert "Evenses")
 +        (insert "Oddses")))
 +    (undo-boundary)
 +    (should
 +     ;; Avoid string-equal because ERT will save the `buffer-string'
 +     ;; to the explanation.  Using `not' will record nil or non-nil.
 +     (not
 +      (null
 +       (string-equal (buffer-string)
 +                     (progn
 +                       (flush-lines "oddses" (point-min) (point-max))
 +                       (undo-boundary)
 +                       (undo)
 +                       (undo)
 +                       (buffer-string))))))))
 +
 +(ert-deftest undo-test5 ()
 +  "Test basic redoing with \\[undo] command."
 +  (with-temp-buffer
 +    (buffer-enable-undo)
 +    (undo-boundary)
 +    (insert "AYE")
 +    (undo-boundary)
 +    (insert " BEE")
 +    (undo-boundary)
 +    (setq buffer-undo-list (cons '(0.0 bogus) buffer-undo-list))
 +    (push-mark nil t)
 +    (delete-region (save-excursion
 +                     (forward-word -1)
 +                     (point)) (point))
 +    (undo-boundary)
 +    (beginning-of-line)
 +    (insert "CEE")
 +    (undo-boundary)
 +    (undo)
 +    (setq buffer-undo-list (cons "bogus" buffer-undo-list))
 +    (should
 +     (string-equal
 +      (buffer-string)
 +      (progn
 +        (if (and (boundp 'undo-test5-error) (not undo-test5-error))
 +            (progn
 +              (should (null (undo-more 2)))
 +              (should (undo)))
 +          ;; Errors are generated by new Lisp version of
 +          ;; `primitive-undo' not by built-in C version.
 +          (should
 +           (equal (should-error (undo-more 2))
 +                  '(error "Unrecognized entry in undo list (0.0 bogus)")))
 +          (should
 +           (equal (should-error (undo))
 +                  '(error "Unrecognized entry in undo list \"bogus\""))))
 +        (buffer-string))))))
 +
 +;; http://debbugs.gnu.org/14824
 +(ert-deftest undo-test-buffer-modified ()
 +  "Test undoing marks buffer unmodified."
 +  (with-temp-buffer
 +    (buffer-enable-undo)
 +    (insert "1")
 +    (undo-boundary)
 +    (set-buffer-modified-p nil)
 +    (insert "2")
 +    (undo)
 +    (should-not (buffer-modified-p))))
 +
 +(ert-deftest undo-test-file-modified ()
 +  "Test undoing marks buffer visiting file unmodified."
 +  (let ((tempfile (make-temp-file "undo-test")))
 +    (unwind-protect
 +        (progn
 +          (with-current-buffer (find-file-noselect tempfile)
 +            (insert "1")
 +            (undo-boundary)
 +            (set-buffer-modified-p nil)
 +            (insert "2")
 +            (undo)
 +            (should-not (buffer-modified-p))))
 +      (delete-file tempfile))))
 +
 +(ert-deftest undo-test-region-not-most-recent ()
 +  "Test undo in region of an edit not the most recent."
 +  (with-temp-buffer
 +    (buffer-enable-undo)
 +    (transient-mark-mode 1)
 +    (insert "1111")
 +    (undo-boundary)
 +    (goto-char 2)
 +    (insert "2")
 +    (forward-char 2)
 +    (undo-boundary)
 +    (insert "3")
 +    (undo-boundary)
 +    ;; Highlight around "2", not "3"
 +    (push-mark (+ 3 (point-min)) t t)
 +    (setq mark-active t)
 +    (goto-char (point-min))
 +    (undo)
 +    (should (string= (buffer-string)
 +                     "11131"))))
 +
 +(ert-deftest undo-test-region-deletion ()
 +  "Test undoing a deletion to demonstrate bug 17235."
 +  (with-temp-buffer
 +    (buffer-enable-undo)
 +    (transient-mark-mode 1)
 +    (insert "12345")
 +    (search-backward "4")
 +    (undo-boundary)
 +    (delete-forward-char 1)
 +    (search-backward "1")
 +    (undo-boundary)
 +    (insert "xxxx")
 +    (undo-boundary)
 +    (insert "yy")
 +    (search-forward "35")
 +    (undo-boundary)
 +    ;; Select "35"
 +    (push-mark (point) t t)
 +    (setq mark-active t)
 +    (forward-char -2)
 +    (undo) ; Expect "4" to come back
 +    (should (string= (buffer-string)
 +                     "xxxxyy12345"))))
 +
 +(ert-deftest undo-test-region-example ()
 +  "The same example test case described in comments for
 +undo-make-selective-list."
 +  ;; buf pos:
 +  ;; 123456789 buffer-undo-list  undo-deltas
 +  ;; --------- ----------------  -----------
 +  ;; aaa       (1 . 4)           (1 . -3)
 +  ;; aaba      (3 . 4)           N/A (in region)
 +  ;; ccaaba    (1 . 3)           (1 . -2)
 +  ;; ccaabaddd (7 . 10)          (7 . -3)
 +  ;; ccaabdd   ("ad" . 6)        (6 . 2)
 +  ;; ccaabaddd (6 . 8)           (6 . -2)
 +  ;;  |   |<-- region: "caab", from 2 to 6
 +  (with-temp-buffer
 +    (buffer-enable-undo)
 +    (transient-mark-mode 1)
 +    (insert "aaa")
 +    (goto-char 3)
 +    (undo-boundary)
 +    (insert "b")
 +    (goto-char 1)
 +    (undo-boundary)
 +    (insert "cc")
 +    (goto-char 7)
 +    (undo-boundary)
 +    (insert "ddd")
 +    (search-backward "ad")
 +    (undo-boundary)
 +    (delete-forward-char 2)
 +    (undo-boundary)
 +    ;; Select "dd"
 +    (push-mark (point) t t)
 +    (setq mark-active t)
 +    (goto-char (point-max))
 +    (undo)
 +    (undo-boundary)
 +    (should (string= (buffer-string)
 +                     "ccaabaddd"))
 +    ;; Select "caab"
 +    (push-mark 2 t t)
 +    (setq mark-active t)
 +    (goto-char 6)
 +    (undo)
 +    (undo-boundary)
 +    (should (string= (buffer-string)
 +                     "ccaaaddd"))))
 +
 +(ert-deftest undo-test-region-eob ()
 +  "Test undo in region of a deletion at EOB, demonstrating bug 16411."
 +  (with-temp-buffer
 +    (buffer-enable-undo)
 +    (transient-mark-mode 1)
 +    (insert "This sentence corrupted?")
 +    (undo-boundary)
 +    ;; Same as recipe at
 +    ;; http://debbugs.gnu.org/cgi/bugreport.cgi?bug=16411
 +    (insert "aaa")
 +    (undo-boundary)
 +    (undo)
 +    ;; Select entire buffer
 +    (push-mark (point) t t)
 +    (setq mark-active t)
 +    (goto-char (point-min))
 +    ;; Should undo the undo of "aaa", ie restore it.
 +    (undo)
 +    (should (string= (buffer-string)
 +                     "This sentence corrupted?aaa"))))
 +
 +(ert-deftest undo-test-marker-adjustment-nominal ()
 +  "Test nominal behavior of marker adjustments."
 +  (with-temp-buffer
 +    (buffer-enable-undo)
 +    (insert "abcdefg")
 +    (undo-boundary)
 +    (let ((m (make-marker)))
 +      (set-marker m 2 (current-buffer))
 +      (goto-char (point-min))
 +      (delete-forward-char 3)
 +      (undo-boundary)
 +      (should (= (point-min) (marker-position m)))
 +      (undo)
 +      (undo-boundary)
 +      (should (= 2 (marker-position m))))))
 +
 +(ert-deftest undo-test-region-t-marker ()
 +  "Test undo in region containing marker with t insertion-type."
 +  (with-temp-buffer
 +    (buffer-enable-undo)
 +    (transient-mark-mode 1)
 +    (insert "abcdefg")
 +    (undo-boundary)
 +    (let ((m (make-marker)))
 +      (set-marker-insertion-type m t)
 +      (set-marker m (point-min) (current-buffer)) ; m at a
 +      (goto-char (+ 2 (point-min)))
 +      (push-mark (point) t t)
 +      (setq mark-active t)
 +      (goto-char (point-min))
 +      (delete-forward-char 1) ;; delete region covering "ab"
 +      (undo-boundary)
 +      (should (= (point-min) (marker-position m)))
 +      ;; Resurrect "ab". m's insertion type means the reinsertion
 +      ;; moves it forward 2, and then the marker adjustment returns it
 +      ;; to its rightful place.
 +      (undo)
 +      (undo-boundary)
 +      (should (= (point-min) (marker-position m))))))
 +
 +(ert-deftest undo-test-marker-adjustment-moved ()
 +  "Test marker adjustment behavior when the marker moves.
 +Demonstrates bug 16818."
 +  (with-temp-buffer
 +    (buffer-enable-undo)
 +    (insert "abcdefghijk")
 +    (undo-boundary)
 +    (let ((m (make-marker)))
 +      (set-marker m 2 (current-buffer)) ; m at b
 +      (goto-char (point-min))
 +      (delete-forward-char 3) ; m at d
 +      (undo-boundary)
 +      (set-marker m 4) ; m at g
 +      (undo)
 +      (undo-boundary)
 +      ;; m still at g, but shifted 3 because deletion undone
 +      (should (= 7 (marker-position m))))))
 +
 +(ert-deftest undo-test-region-mark-adjustment ()
 +  "Test that the mark's marker adjustment in undo history doesn't
 +obstruct undo in region from finding the correct change group.
 +Demonstrates bug 16818."
 +  (with-temp-buffer
 +    (buffer-enable-undo)
 +    (transient-mark-mode 1)
 +    (insert "First line\n")
 +    (insert "Second line\n")
 +    (undo-boundary)
 +
 +    (goto-char (point-min))
 +    (insert "aaa")
 +    (undo-boundary)
 +
 +    (undo)
 +    (undo-boundary)
 +
 +    (goto-char (point-max))
 +    (insert "bbb")
 +    (undo-boundary)
 +
 +    (push-mark (point) t t)
 +    (setq mark-active t)
 +    (goto-char (- (point) 3))
 +    (delete-forward-char 1)
 +    (undo-boundary)
 +
 +    (insert "bbb")
 +    (undo-boundary)
 +
 +    (goto-char (point-min))
 +    (push-mark (point) t t)
 +    (setq mark-active t)
 +    (goto-char (+ (point) 3))
 +    (undo)
 +    (undo-boundary)
 +
 +    (should (string= (buffer-string) "aaaFirst line\nSecond line\nbbb"))))
 +
 +(defun undo-test-all (&optional interactive)
 +  "Run all tests for \\[undo]."
 +  (interactive "p")
 +  (if interactive
 +      (ert-run-tests-interactively "^undo-")
 +    (ert-run-tests-batch "^undo-")))
 +
 +(provide 'undo-tests)
 +;;; undo-tests.el ends here
diff --cc test/src/xml-tests.el
index dc60197b59e,00000000000..1550887f77d
mode 100644,000000..100644
--- a/test/src/xml-tests.el
+++ b/test/src/xml-tests.el
@@@ -1,74 -1,0 +1,74 @@@
 +;;; libxml-parse-tests.el --- Test suite for libxml parsing.
 +
- ;; Copyright (C) 2014-2016 Free Software Foundation, Inc.
++;; Copyright (C) 2014-2017 Free Software Foundation, Inc.
 +
 +;; Author: Ulf Jasper <ulf.jasper@web.de>
 +;; Keywords:       internal
 +;; Human-Keywords: internal
 +
 +;; This file is part of GNU Emacs.
 +
 +;; GNU Emacs is free software: you can redistribute it and/or modify
 +;; it under the terms of the GNU General Public License as published by
 +;; the Free Software Foundation, either version 3 of the License, or
 +;; (at your option) any later version.
 +
 +;; GNU Emacs is distributed in the hope that it will be useful,
 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 +;; GNU General Public License for more details.
 +
 +;; You should have received a copy of the GNU General Public License
 +;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
 +
 +;;; Commentary:
 +
 +;;; Code:
 +
 +(require 'ert)
 +
 +(defvar libxml-tests--data-comments-preserved
 +  `(;; simple case
 +    ("<?xml version=\"1.0\"?><foo baz=\"true\">bar</foo>"
 +     . (foo ((baz . "true")) "bar"))
 +    ;; toplevel comments -- first document child must not get lost
 +    (,(concat "<?xml version=\"1.0\"?><foo>bar</foo><!--comment-1-->"
 +	      "<!--comment-2-->")
 +     . (top nil (foo nil "bar") (comment nil "comment-1")
 +            (comment nil "comment-2")))
 +    (,(concat "<?xml version=\"1.0\"?><!--comment-a--><foo a=\"b\">"
 +	      "<bar>blub</bar></foo><!--comment-b--><!--comment-c-->")
 +     . (top nil (comment nil "comment-a") (foo ((a . "b")) (bar nil "blub"))
 +            (comment nil "comment-b") (comment nil "comment-c"))))
 +  "Alist of XML strings and their expected parse trees for preserved comments.")
 +
 +(defvar libxml-tests--data-comments-discarded
 +  `(;; simple case
 +    ("<?xml version=\"1.0\"?><foo baz=\"true\">bar</foo>"
 +     . (foo ((baz . "true")) "bar"))
 +    ;; toplevel comments -- first document child must not get lost
 +    (,(concat "<?xml version=\"1.0\"?><foo>bar</foo><!--comment-1-->"
 +	      "<!--comment-2-->")
 +     . (foo nil "bar"))
 +    (,(concat "<?xml version=\"1.0\"?><!--comment-a--><foo a=\"b\">"
 +	      "<bar>blub</bar></foo><!--comment-b--><!--comment-c-->")
 +     . (foo ((a . "b")) (bar nil "blub"))))
 +  "Alist of XML strings and their expected parse trees for discarded comments.")
 +
 +
 +(ert-deftest libxml-tests ()
 +  "Test libxml."
 +  (when (fboundp 'libxml-parse-xml-region)
 +    (with-temp-buffer
 +      (dolist (test libxml-tests--data-comments-preserved)
 +        (erase-buffer)
 +        (insert (car test))
 +        (should (equal (cdr test)
 +                       (libxml-parse-xml-region (point-min) (point-max)))))
 +      (dolist (test libxml-tests--data-comments-discarded)
 +        (erase-buffer)
 +        (insert (car test))
 +        (should (equal (cdr test)
 +                       (libxml-parse-xml-region (point-min) (point-max) nil t)))))))
 +
 +;;; libxml-tests.el ends here